├── .gitignore ├── Changes ├── MANIFEST ├── MANIFEST.SKIP ├── META.yml ├── MYMETA.yml ├── Makefile.PL ├── README.md ├── bin ├── atnodes ├── fornodes ├── key2nodes └── tonodes ├── inc ├── Module │ ├── AutoInstall.pm │ ├── Install.pm │ └── Install │ │ ├── AutoInstall.pm │ │ ├── Base.pm │ │ ├── Can.pm │ │ ├── Fetch.pm │ │ ├── Include.pm │ │ ├── Makefile.pm │ │ ├── Metadata.pm │ │ ├── Scripts.pm │ │ ├── TestBase.pm │ │ ├── Win32.pm │ │ └── WriteAll.pm ├── Spiffy.pm └── Test │ ├── Base.pm │ ├── Base │ └── Filter.pm │ ├── Builder.pm │ ├── Builder │ └── Module.pm │ └── More.pm ├── lib └── SSH │ ├── Batch.pm │ └── Batch │ └── ForNodes.pm └── t ├── 99-pod-coverage.t ├── 99-pod.t ├── agentzh.t ├── atnodes.pm ├── atnodes.t ├── fornodes.pm ├── fornodes.t ├── tonodes.pm └── tonodes.t /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.json 3 | *.o 4 | *.hi 5 | !*.t.json 6 | cover_db 7 | Makefile 8 | blib 9 | *.old 10 | *.swp 11 | pm_to_blib 12 | share/font 13 | t/*.dat 14 | *.tar.gz 15 | t/tmp 16 | .rsync 17 | 18 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 0.030 2 | - atnodes: added the -W option to atnodes to allow prompting 3 | for passwords for sudo only. thanks JamesPan for the patch. 4 | 5 | 0.029 6 | - atnodes: added a '-q' parameter to run SSH in quiet mode, 7 | which prevents banners and motd messages from being 8 | displayed in the output. thanks Mithun Ayachit for the patch. 9 | 10 | 0.028 11 | - atnodes: fixed tmp file leaks. 12 | - atnodes: automatically check if openssh version >= 4.1. 13 | 14 | 0.027 15 | - added support for the environment SSH_BATCH_RC to specify a 16 | different file name than the default ~/.fornodesrc. 17 | thanks Mithun Ayachit. 18 | - updated host variable format check to /\w[-\.\w]*/. 19 | - added the SSH_BATCH_PASSPHRASE environment for -P and 20 | SSH_BATCH_PASSWORD env for -w. 21 | - added passphrase support. 22 | - added some docs for tty option. 23 | 24 | 0.024 25 | - tonodes: added rsync archive, update and compress mode. (liseen) 26 | - fornodes: trim expressions when parsing them. (liseen) 27 | - atnodes: added the use-tty option. 28 | - fornodes: now we automatically create a default ~/.fornodesrc when it's missing. 29 | - atnodes: added the "StrictHostChecking no" option for the first login. 30 | 31 | 0.023 32 | - key2nodes: more examples added to SYNOPSIS in its POD. thanks cnhackTNT++. 33 | - added repository address into Makefile.PL, thanks Alexandr Ciornii. 34 | 35 | 0.022 36 | - tonodes: now we automatically expand ~ and ~foo using local USER env if set 37 | - added support for SSH_BATCH_SSH_CMD env and --ssh option to key2nodes. 38 | - tonodes now print a warning message while expanding ~ and ~foo locally in the target path. 39 | - added more docs explaining how to disable StrictHostKeyChecking for ssh 40 | 41 | 0.021 42 | - fixed the homedir mocking bug of the test suite for Mac. 43 | - no longer skipped those tests marked as linux_only on non-linux systems. 44 | 45 | 0.020 46 | - explains the "sudo: sorry, you must have a tty to run sudo" error a bit in 47 | the POD. 48 | - fixed the license name in Makefile.PL (and thus META.yml too). 49 | 50 | 0.019 51 | - fixed the typo in the fornodes usage and docs. it should be -x rather than 52 | -l. 53 | - fixed the test suite on non-linux systems. 54 | 55 | 0.018 56 | - now the fornodes script puts hosts in a single line. use -x to get the 57 | old one-host-per-line behavior. 58 | - now the use can set the SSH_BATCH_LINE_MODE env to set -L for every 59 | atnodes/tonodes execution. 60 | 61 | 0.017 62 | - now in the test scaffold, we use LC_ALL=C rather than LC_ALL=en_US.UTF-8. 63 | the latter is not available on certain systems. 64 | - skipped the "no home" tests on non-linux systems. 65 | - minor doc fixes. 66 | 67 | 0.016 68 | - fixed a doc typo found by franck. 69 | 70 | 0.015 71 | - added a tip for port and user name integration in the cluster spec 72 | expressions. 73 | 74 | 0.014 75 | - display Net::OpenSSH's error messages when failures occur. 76 | - added a lot more docs. 77 | 78 | 0.013 79 | - apply the invalid PID fixes to tonodes and key2nodes as well. 80 | - implemented -L option in tonodes. 81 | - now we install key2nodes in Makefile.PL as well. 82 | 83 | 0.012 84 | - fixed the special case when Net::OpenSSH::spawn returns invalid PID (-1). 85 | 86 | 0.011 87 | - now we ignore user's SSH_BATCH_SSH_CMD environment settings in the test 88 | scaffold, fixing a bogus test failure on some user's machines with 89 | the env set. 90 | 91 | 0.010 92 | - added -L option to use host-very-output-line output format. 93 | 94 | 0.009 95 | - ignored status code difference in t/fornodes.pm so that there won't be 96 | bogus test failures on BSD. 97 | - added support for the SSH_BATCH_SSH_CMD environment to let user specify 98 | his own ssh path. But it could be further overriden by the -ssh command 99 | line option. 100 | - added docs to explain how to pass custom options to the underlying "ssh" 101 | program by means of custom ssh wrapper scripts. 102 | - added docs to make clear that we require at least OpenSSH 4.1 client 103 | side executable "ssh". 104 | 105 | 0.008 106 | - added -ssh option to atnodes. 107 | 108 | 0.007 109 | - added -c option to atnodes/tonodes/key2nodes and it has the 110 | default SSH concurrency limit of 20. 111 | - skip directories in tonode if no -r specified. 112 | 113 | 0.006 114 | - fixed a bug in multiline expression handling in ~/.fornodesrc parsing. 115 | - added multi-line expression samples to the POD docs. 116 | 117 | 0.005 118 | - updated the POD docs. 119 | - fixed the bogus test failures on machines with a different locale. 120 | 121 | 0.004 122 | - no longer set tty => 1 explicitly to Net::OpenSSH's call. 123 | - implemented the set division operator. 124 | - now we consider set opeartor precedence. 125 | - added -rsync option to tonodes to use "rsync" rather than the default "scp". 126 | - added -b option to limit transfer bandwidth. 127 | 128 | 0.003 129 | - added the key2nodes script. 130 | - fixed the waitpid bug in atnodes. 131 | - minor doc cleanup. 132 | 133 | 0.002 134 | - added the tonodes script. 135 | - more tests added. 136 | - more docs added. 137 | 138 | 0.001 139 | - initial CPAN release. 140 | 141 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | bin/atnodes 2 | Changes 3 | inc/Module/Install/TestBase.pm 4 | inc/Spiffy.pm 5 | inc/Test/Base.pm 6 | inc/Test/Base/Filter.pm 7 | inc/Test/Builder.pm 8 | inc/Test/Builder/Module.pm 9 | inc/Test/More.pm 10 | t/99-pod-coverage.t 11 | t/99-pod.t 12 | t/atnodes.pm 13 | t/atnodes.t 14 | t/fornodes.pm 15 | t/fornodes.t 16 | bin/tonodes 17 | t/agentzh.t 18 | t/tonodes.pm 19 | t/tonodes.t 20 | bin/key2nodes 21 | bin/fornodes 22 | inc/Module/AutoInstall.pm 23 | inc/Module/Install.pm 24 | inc/Module/Install/AutoInstall.pm 25 | inc/Module/Install/Base.pm 26 | inc/Module/Install/Can.pm 27 | inc/Module/Install/Fetch.pm 28 | inc/Module/Install/Include.pm 29 | inc/Module/Install/Makefile.pm 30 | inc/Module/Install/Metadata.pm 31 | inc/Module/Install/Scripts.pm 32 | inc/Module/Install/Win32.pm 33 | inc/Module/Install/WriteAll.pm 34 | lib/SSH/Batch.pm 35 | lib/SSH/Batch/ForNodes.pm 36 | Makefile.PL 37 | MANIFEST This list of files 38 | MANIFEST.SKIP 39 | META.yml 40 | README.md 41 | MYMETA.json 42 | MYMETA.yml 43 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^tmp 2 | \.swp$ 3 | ~$ 4 | ^blib 5 | ^smerge$ 6 | ^Makefile$ 7 | \.old$ 8 | pm_to_blib 9 | \.bak$ 10 | \.git* 11 | po/foo\.po$ 12 | po/meta\.po$ 13 | t/tmp 14 | ^\.rsync$ 15 | ^reindex$ 16 | -------------------------------------------------------------------------------- /META.yml: -------------------------------------------------------------------------------- 1 | --- 2 | abstract: 'Cluster operations based on parallel SSH, set and interval arithmetic' 3 | author: 4 | - 'Zhang "agentzh" Yichun ' 5 | build_requires: 6 | ExtUtils::MakeMaker: 6.59 7 | IPC::Run3: 0 8 | configure_requires: 9 | ExtUtils::MakeMaker: 6.59 10 | distribution_type: module 11 | dynamic_config: 1 12 | generated_by: 'Module::Install version 1.14' 13 | license: bsd 14 | meta-spec: 15 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 16 | version: 1.4 17 | name: SSH-Batch 18 | no_index: 19 | directory: 20 | - inc 21 | - t 22 | requires: 23 | File::HomeDir: 0 24 | File::Temp: 0 25 | Filter::Util::Call: 0 26 | IO::Pty: 0 27 | Net::OpenSSH: '0.34' 28 | Set::Scalar: '1.23' 29 | Term::ReadKey: '2.30' 30 | Time::HiRes: 0 31 | perl: 5.6.1 32 | resources: 33 | license: http://opensource.org/licenses/bsd-license.php 34 | repository: http://github.com/agentzh/sshbatch 35 | version: '0.030' 36 | -------------------------------------------------------------------------------- /MYMETA.yml: -------------------------------------------------------------------------------- 1 | --- 2 | abstract: 'Cluster operations based on parallel SSH, set and interval arithmetic' 3 | author: 4 | - 'Zhang "agentzh" Yichun ' 5 | build_requires: 6 | ExtUtils::MakeMaker: '6.59' 7 | IPC::Run3: '0' 8 | configure_requires: 9 | ExtUtils::MakeMaker: '0' 10 | dynamic_config: 0 11 | generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' 12 | license: bsd 13 | meta-spec: 14 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 15 | version: '1.4' 16 | name: SSH-Batch 17 | no_index: 18 | directory: 19 | - t 20 | - inc 21 | requires: 22 | File::HomeDir: '0' 23 | File::Temp: '0' 24 | Filter::Util::Call: '0' 25 | IO::Pty: '0' 26 | Net::OpenSSH: '0.34' 27 | Set::Scalar: '1.23' 28 | Term::ReadKey: '2.30' 29 | Time::HiRes: '0' 30 | perl: '5.006001' 31 | version: '0.030' 32 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use lib '.'; 3 | use inc::Module::Install; 4 | 5 | name ('SSH-Batch'); 6 | license ('bsd'); 7 | author ('Zhang "agentzh" Yichun '); 8 | perl_version ('5.006001'); 9 | all_from ('lib/SSH/Batch.pm'); 10 | 11 | repository 'http://github.com/agentzh/sshbatch'; 12 | 13 | requires ('Set::Scalar' => '1.23'); 14 | requires ('File::HomeDir'); 15 | requires ('Net::OpenSSH' => '0.34'); 16 | requires ('File::Temp'); 17 | requires ('Term::ReadKey' => '2.30'); 18 | requires ('IO::Pty'); 19 | requires ('Time::HiRes'); 20 | 21 | build_requires ('IPC::Run3'); 22 | #build_requires ('Test::Base' => '0.54'); 23 | 24 | use_test_base; 25 | 26 | no_index( directory => qw< t inc doc share demo > ); 27 | 28 | install_script ('bin/fornodes'); 29 | install_script ('bin/atnodes'); 30 | install_script ('bin/tonodes'); 31 | install_script ('bin/key2nodes'); 32 | 33 | auto_install(); 34 | WriteAll(); 35 | 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | SSH::Batch - Cluster operations based on parallel SSH, set and interval arithmetic 4 | 5 | Table of Contents 6 | ================= 7 | 8 | * [NAME](#name) 9 | * [VERSION](#version) 10 | * [SYNOPSIS](#synopsis) 11 | * [DESCRIPTION](#description) 12 | * [TIPS](#tips) 13 | * [PREREQUISITES](#prerequisites) 14 | * [INSTALLATION](#installation) 15 | * [CODE REPOSITORY](#code-repository) 16 | * [TODO](#todo) 17 | * [AUTHORS](#authors) 18 | * [COPYRIGHT & LICENSE](#copyright--license) 19 | * [SEE ALSO](#see-also) 20 | 21 | # VERSION 22 | 23 | This document describes SSH::Batch 0.030 released on 8 November 2015. 24 | 25 | # SYNOPSIS 26 | 27 | The following scripts are provided: 28 | 29 | - fornodes 30 | 31 | Expand patterns to machine host list. 32 | 33 | $ cat > ~/.fornodesrc 34 | ps=blah.ps.com bloo.ps.com boo[2-25,32,41-70].ps.com 35 | as=ws[1101-1105].as.com 36 | # use set operations to define new sets: 37 | foo={ps} + {ps} * {as} - {ps} / {as} 38 | bar = foo.com bar.org \ 39 | bah.cn \ 40 | baz.com 41 | ^D 42 | 43 | $ fornodes 'api[02-10].foo.bar.com' 'boo*.ps.com' 44 | $ fornodes 'tq[ab-ac].[1101-1105].foo.com' 45 | $ fornodes '{ps} + {as} - ws1104.as.com' # set union and subtraction 46 | $ fornodes '{ps} * {as}' # set intersect 47 | 48 | - atnodes 49 | 50 | Run command on clusters. (atnodes calls fornodes internally.) 51 | 52 | # run a command on the specified servers: 53 | $ atnodes $'ps -fe|grep httpd' 'ws[1101-1105].as.com' 54 | 55 | # multiple-arg command requires "--": 56 | $ atnodes ls /opt/ -- '{ps} + {as}' 'localhost' 57 | 58 | # or use single arg command: 59 | $ atnodes 'ls /opt/' '{ps} + {as}' 'localhost' # ditto 60 | 61 | # specify a different user name and SSH server port: 62 | $ atnodes hostname '{ps}' -u agentz -p 12345 63 | 64 | # use -w to prompt for password if w/o SSH key (no echo back) 65 | $ atnodes hostname '{ps}' -u agentz -w 66 | 67 | # or prompt for password if both login and sudo are required... 68 | $ atnodes 'sudo apachectl restart' '{ps}' -w 69 | 70 | # or prompt for password for sudo only... 71 | $ atnodes 'sudo apachectl restart' '{ps}' -W 72 | 73 | # run sudo command if tty required... 74 | $ atnodes -tty 'sudo apachectl restart' '{ps}' 75 | 76 | # or specify a timeout: 77 | $ atnodes 'ping foo.com' '{ps}' -t 3 78 | 79 | - tonodes 80 | 81 | Upload local files/directories to remote clusters 82 | 83 | $ tonodes /tmp/*.inst -- '{as}:/tmp/' 84 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt 85 | 86 | # use rsync instead of scp: 87 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync 88 | 89 | $ tonodes -r /opt /bin/* -- 'ws[1101-1102].foo.com' 'bar.com' :/foo/bar/ 90 | 91 | - key2nodes 92 | 93 | Push the SSH public key (or generate one if not any) to the remote clusters. 94 | 95 | $ key2nodes 'ws[1101-1105].as.com' 96 | 97 | # DESCRIPTION 98 | 99 | System administration (sysadmin) is also part of my `$work`. Playing with a (big) bunch of machines without a handy tool is painful. So I refactored some of our old scripts and hence this module. 100 | 101 | This is a high-level abstraction over the powerful [Net::OpenSSH](https://metacpan.org/pod/Net::OpenSSH) module. A bunch of handy scripts are provided to simplify big cluster operations: [fornodes](https://metacpan.org/pod/fornodes), [atnodes](https://metacpan.org/pod/atnodes), [tonodes](https://metacpan.org/pod/tonodes), and [key2nodes](https://metacpan.org/pod/key2nodes). 102 | 103 | `SSH::Batch` allows you to name your clusters using variables and interval/set syntax in your `~/.fornodesrc` config file (or a different file name specified by the `SSH_BATCH_RC` environment). For instance: 104 | 105 | $ cat ~/.fornodesrc 106 | A=foo[01-03].com bar.org 107 | B=bar.org baz[a-b,d,e-g].cn foo02.com 108 | C={A} * {B} 109 | D={A} - {B} 110 | 111 | where cluster `C` is the intersection set of cluster `A` and `B` while `D` is the sef of machines that are in `A` but not in `B`. 112 | 113 | And then you can query machine host list by using `SSH::Batch`'s [fornodes](https://metacpan.org/pod/fornodes) script: 114 | 115 | $ fornodes '{C}' 116 | bar.org foo02.com 117 | 118 | $ fornodes '{D}' 119 | foo01.com foo03.com 120 | 121 | $ fornodes blah.com '{C} + {D}' 122 | bar.org blah.com foo01.com foo02.com foo03.com 123 | 124 | It's always best practice to **put spaces around set operators** like `+`, `-`, `*`, and `/`, so as to allow these characters (notably the dash `-`) in your host names, as in: 125 | 126 | $ fornodes 'foo-bar-[a-d].com - foo-bar-c.com' 127 | foo-bar-a.com foo-bar-b.com foo-bar-d.com 128 | 129 | for the ranges like `[a-z]`, there's also an alternative syntax: 130 | 131 | [a..z] 132 | 133 | To exclude some discrete values from certain range, you need set subtration: 134 | 135 | foo[1-100].com - foo[32,56].com 136 | 137 | or equivalently 138 | 139 | foo[1-31,33-55,57-100].com 140 | 141 | [fornodes](https://metacpan.org/pod/fornodes) could be very handy in shell programming. For example, to test the 80 port HTTP service of a cluster `A`, simply put 142 | 143 | $ for node in `fornodes '{A}'`; \ 144 | do curl "http://$node:80/blah'; \ 145 | done 146 | 147 | Also, other scripts in this module, like [atnodes](https://metacpan.org/pod/atnodes), [tonodes](https://metacpan.org/pod/tonodes), and [key2nodes](https://metacpan.org/pod/key2nodes) also call fornodes internally so that you can use the cluster spec syntax in those scripts' command line as well. 148 | 149 | [atnodes](https://metacpan.org/pod/atnodes) meets the common requirement of running a command on a remote cluster. For example: 150 | 151 | # at the concurrency level of 6: 152 | atnodes 'ls -lh' '{A} + {B}' my.more.com -c 6 153 | 154 | Or upload a local file to the remote cluster: 155 | 156 | tonodes ~/my.tar.gz '{A} / {B}' :/tmp/ 157 | 158 | or multiple files as well as some directories: 159 | 160 | tonodes -r ~/mydir ~/mydir2/*.so -- foo.com bar.cn :~/ 161 | 162 | It's also possible to use wildcards in the cluster spec expression, as in 163 | 164 | atnodes 'ls ~' 'api??.*.com' 165 | 166 | where [atnodes](https://metacpan.org/pod/atnodes) will match the pattern `api??.*.com` against the "universal set" consisting of those hosts appeared in `~/fornodesrc` and those host names apeared before this pattern on the command line (if any). Note that only `?` (match any character) and `*` (match 0 or more characters) are supported here. 167 | 168 | There's also a [key2nodes](https://metacpan.org/pod/key2nodes) script to push SSH public keys to remote machines ;) 169 | 170 | [Back to TOC](#table-of-contents) 171 | 172 | # TIPS 173 | 174 | There's some extra tips found in our own's everyday use: 175 | 176 | - Running sudo commands 177 | 178 | Often, we want to run commands requiring root access, such as when installing 179 | software packages on remote machines. So you'll have to tell [atnodes](https://metacpan.org/pod/atnodes) to 180 | prompt for your password: 181 | 182 | $ atnodes 'sudo yum install blah' '{my_cluster}' -w 183 | 184 | Then you'll be prompted by the `Password:` prompt after which you enter your 185 | remote password (with echo back turned off). 186 | 187 | Because the remote `sshd` might be smart enough to "remember" the sudo password 188 | for a (small) amount of time, immediate subsequent "sudo" might omit the `-w` option, as in 189 | 190 | $ atnodes 'sudo mv ~/foo /usr/local/bin/' {my_cluster} 191 | 192 | But remember, you can use _sudo without passwords_ just for a _small_ amount of 193 | time ;) 194 | 195 | If you see the following error message while doing sudo with [atnodes](https://metacpan.org/pod/atnodes) 196 | 197 | sudo: sorry, you must have a tty to run sudo 198 | 199 | then you should add option -tty, or you can probably comment out the "Defaults requiretty" line in your server's `/etc/sudoers` file (best just to do this for your own account). 200 | 201 | - Passing custom options to the underlying `ssh` 202 | 203 | By default, `atnodes` relies on [Net::OpenSSH](https://metacpan.org/pod/Net::OpenSSH) to locate the OpenSSH client executable "ssh". But you can define the `SSH_BATCH_SSH_CMD` environment to specify the command explicitly. You can use the `-ssh` option to override it further. (The [key2nodes](https://metacpan.org/pod/key2nodes) script also supports the `SSH_BATCH_SSH_CMD` environment.) 204 | 205 | Note that to specify your own "ssh" is also a way to pass more options to the underlying OpenSSH client executable when using `atnodes`: 206 | 207 | $ cat > ~/bin/myssh 208 | #!/bin/sh 209 | # to enable X11 forwarding: 210 | exec ssh -X "$@" 211 | ^D 212 | 213 | $ chmod +x ~/bin/myssh 214 | 215 | $ export SSH_BATCH_SSH_CMD=~/bin/myssh 216 | $ atnodes 'ls -lh' '{my_cluster_name}' 217 | 218 | It's important to use "exec" in your own ssh wrapper script, or you may see `atnodes` hangs. 219 | 220 | This trick also works for the [key2nodes](https://metacpan.org/pod/key2nodes) script. 221 | 222 | - Use wildcard for cluster expressions to save typing 223 | 224 | Wildcards in cluster spec could save a lot of typing. Say, if you have 225 | `api10.foo.bar.baz.bah.com.cn` appeared in your `~/.fornodesrc` file: 226 | 227 | $ cat ~/.fornodesrc 228 | MyCluster=api[01-22].foo.bar.baz.bah.com.cn 229 | 230 | then in case you want to refer to the `api10.foo.bar.baz.bah.com.cn` node alone on the command line, you can just say `api10*`, or `api10.*.com.cn`, or something more specific. 231 | 232 | But use wildcards with care. You may have nodes that you don't want in your 233 | resulting host list. So it's best practice to use [-l](https://metacpan.org/pod/-l) option when you use 234 | wildcards with [atnodes](https://metacpan.org/pod/atnodes) or [tonodes](https://metacpan.org/pod/tonodes), as in 235 | 236 | $ atnodes 'rm -rf /opt/blah' 'api10*' -l 237 | 238 | So that [atnodes](https://metacpan.org/pod/atnodes) will just echos out the exact host list that it would 239 | operate on but without doing anything. (It's effectively a "dry-run".) 240 | After checking, you can safely remove the `-l` option and go on. 241 | 242 | - Specify a different ssh port or user name. 243 | 244 | You may have already learned that you can use the `-u` and `-p` options to specify a non-default user account or SSH port. But it's also possible and often more convenient to put it as part of your cluster spec expression, either in `~/.fornodesrc` or on the command line, as in 245 | 246 | $ cat > ~/.fornodesrc 247 | # cluster A uses the default user name: 248 | A=foo[01-25].com 249 | # cluster B uses the non-default user name "jim" and a port 12345 250 | B=jim@foo[26-28].com:12345 251 | 252 | $ atnodes 'ls -lh' '{B} + bob@bar[29-31].org:5678' 253 | 254 | It's also possible to specify a different rc config file than `~/.fornodesrc` via the environment variable `SSH_BATCH_RC`. For example, 255 | 256 | export SSH_BATCH_RC=/opt/my-fornodes-rc 257 | 258 | then the file `/opt/my-fornodes-rc` will be used instead of the default `~/.fornodesrc` file. 259 | 260 | - Use `-L` to help grepping the outputs by hostname 261 | 262 | When managing hundreds or even thousands of machines, it's often more 263 | convenient to `grep` over the outputs of [atnodes](https://metacpan.org/pod/atnodes) or [tonodes](https://metacpan.org/pod/tonodes) by 264 | host names. The `-L` option makes [atnodes](https://metacpan.org/pod/atnodes) and [tonodes](https://metacpan.org/pod/tonodes) to prefixing 265 | every output lines of the remote commands (if any) by the host name. As in 266 | 267 | $ atnodes 'top -b|head -n5' '{my_big_cluster}' -L > out.txt 2>&1 268 | $ grep 'some.specific.host.com' out.txt 269 | 270 | - Specify a timeout to prevent hanging 271 | 272 | It's often wise to specify a timeout for SSH operations. For example, 273 | if there's 3 sec of network traffic silence, the following command will 274 | quit with an error message printed: 275 | 276 | $ atnodes -t 3 'sleep 4' {my_cluster} 277 | 278 | - Limit the bandwith used by [tonodes](https://metacpan.org/pod/tonodes) to be firewall-friendly 279 | 280 | You can use the `-b` option to tell [tonodes](https://metacpan.org/pod/tonodes) to use limited bandwidth 281 | if your intranet's Firewall is paranoid about your bandwidth use: 282 | 283 | $ tonodes my_big_file {my_cluster}:/tmp/ -b 8000 284 | 285 | where `8000` is in the unit of Kbits/sec, so it will not transfer 286 | faster than 1 MByte/sec. 287 | 288 | - Avoid logging manually for the first time 289 | 290 | When you use [key2nodes](https://metacpan.org/pod/key2nodes) or [atnodes](https://metacpan.org/pod/atnodes) to access remote servers 291 | that you have never logged in manually, you would probably see the 292 | following errors: 293 | 294 | ===================== foo.com ===================== 295 | Failed to spawn command. 296 | 297 | ERROR: unable to establish master SSH connection: the authenticity of the target host can't be established, try loging manually first 298 | 299 | A work-around is using "ssh" to login to that `foo.com` machine 300 | manually and then try [key2nodes](https://metacpan.org/pod/key2nodes) or [atnodes](https://metacpan.org/pod/atnodes) again. 301 | 302 | Another nicer work-around is to pass the `-o 'StrictHostKeyChecking=no'` option to the underlying `ssh` executable used by `SSH::Batch`. 303 | Here's a quick HOW-TO: 304 | 305 | $ cat > ~/bin/myssh 306 | #!/bin/sh 307 | # to disable StrictHostKeyChecking 308 | exec ssh -o 'StrictHostKeyChecking=no' "$@" 309 | ^D 310 | 311 | $ chmod +x ~/bin/myssh 312 | 313 | $ export SSH_BATCH_SSH_CMD=~/bin/myssh 314 | 315 | # then we try again 316 | $ key2nodes foo.com 317 | $ atnodes 'hostname' foo.com 318 | 319 | [Back to TOC](#table-of-contents) 320 | 321 | # PREREQUISITES 322 | 323 | This module uses [Net::OpenSSH](https://metacpan.org/pod/Net::OpenSSH) behind the scene, so it requires the OpenSSH _client_ executable (usually spelled "ssh") with multiplexing support (at least OpenSSH 4.1). To check your `ssh` version, use the command: 324 | 325 | $ ssh -v 326 | 327 | On my machine, it echos 328 | 329 | OpenSSH_4.7p1 Debian-8ubuntu1.2, OpenSSL 0.9.8g 19 Oct 2007 330 | usage: ssh [-1246AaCfgKkMNnqsTtVvXxY] [-b bind_address] [-c cipher_spec] 331 | [-D [bind_address:]port] [-e escape_char] [-F configfile] 332 | [-i identity_file] [-L [bind_address:]port:host:hostport] 333 | [-l login_name] [-m mac_spec] [-O ctl_cmd] [-o option] [-p port] [-R [bind_address:]port:host:hostport] [-S ctl_path] 334 | [-w local_tun[:remote_tun]] [user@]hostname [command] 335 | 336 | There's no spesial requirement on the server side ssh service. Even a non-OpenSSH server-side deamon should work as well. 337 | 338 | [Back to TOC](#table-of-contents) 339 | 340 | # INSTALLATION 341 | 342 | perl Makefile.PL 343 | make 344 | make test 345 | sudo make install 346 | 347 | Win32 users should replace "make" with "nmake". 348 | 349 | [Back to TOC](#table-of-contents) 350 | 351 | # CODE REPOSITORY 352 | 353 | You can always get the latest `SSH::Batch` source from its public Git repository: 354 | 355 | [http://github.com/agentzh/sshbatch](http://github.com/agentzh/sshbatch) 356 | 357 | If you have a branch for me to pull, please let me know ;) 358 | 359 | [Back to TOC](#table-of-contents) 360 | 361 | # TODO 362 | 363 | - Cache the parsing and evaluation results of the config file `~/.fornodesrc` 364 | to somewhere like the fiel `~/.fornodesrc.cached`. 365 | - Abstract the duplicate code found in the scripts to a shared .pm file. 366 | - Add the `fromnodes` script to help downloading files from the remote 367 | clusters to local file system (maybe grouped by host name). 368 | - Add the `betweennodes` script to transfer files between clusters through 369 | localhost. 370 | 371 | [Back to TOC](#table-of-contents) 372 | 373 | # AUTHORS 374 | 375 | - Zhang "agentzh" Yichun (章亦春) `` 376 | - Liseen Wan (万珣新) `` 377 | 378 | [Back to TOC](#table-of-contents) 379 | 380 | # COPYRIGHT & LICENSE 381 | 382 | This module as well as its programs are licensed under the BSD License. 383 | 384 | Copyright (C) 2009-2015, Yichun "agentzh" Zhang (章亦春). All rights reserved. 385 | 386 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 387 | 388 | - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 389 | - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 390 | - Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 391 | 392 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 393 | 394 | [Back to TOC](#table-of-contents) 395 | 396 | # SEE ALSO 397 | 398 | [fornodes](https://metacpan.org/pod/fornodes), [atnodes](https://metacpan.org/pod/atnodes), [tonodes](https://metacpan.org/pod/tonodes), [key2nodes](https://metacpan.org/pod/key2nodes), 399 | [SSH::Batch::ForNodes](https://metacpan.org/pod/SSH::Batch::ForNodes), [Net::OpenSSH](https://metacpan.org/pod/Net::OpenSSH). 400 | 401 | [Back to TOC](#table-of-contents) 402 | 403 | -------------------------------------------------------------------------------- /bin/atnodes: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | #use Smart::Comments::JSON '##'; 7 | use lib 'lib'; 8 | use Net::OpenSSH; 9 | use Term::ReadKey; 10 | use SSH::Batch::ForNodes; 11 | use File::Temp qw/ :POSIX /; 12 | use Time::HiRes qw/sleep/; 13 | 14 | sub help ($); 15 | sub check_openssh_version ($); 16 | 17 | if (!@ARGV) { 18 | warn "No argument specified.\n\n"; 19 | help(1); 20 | } 21 | 22 | my $list_hosts_only = 0; 23 | my ($user, $port, $timeout, $verbose, $ask_for_pass); 24 | my ($ask_for_pass_only_for_sudo, $ask_for_passphrase); 25 | my $concurrency = 20; 26 | my (@cmd, @exprs, $ssh_cmd); 27 | $ssh_cmd = $ENV{SSH_BATCH_SSH_CMD}; 28 | 29 | my $fetch_value; 30 | my $found_sep; 31 | my $last_option; 32 | my $use_tty; 33 | my $use_quiet_mode; 34 | my $line_mode = $ENV{SSH_BATCH_LINE_MODE}; 35 | for (@ARGV) { 36 | if (defined $fetch_value) { 37 | $fetch_value->($_); 38 | undef $fetch_value; 39 | next; 40 | } 41 | if ($_ eq '--') { 42 | @cmd = @exprs; 43 | @exprs = (); 44 | $found_sep = 1; 45 | next; 46 | } 47 | if (/^-(.*)/) { 48 | my $group = $1; 49 | if ($group eq 'l') { 50 | $list_hosts_only = 1; 51 | } elsif ($group eq 'u') { 52 | $fetch_value = sub { $user = shift }; 53 | } elsif ($group eq 't') { 54 | $fetch_value = sub { $timeout = shift }; 55 | } elsif ($group eq 'h') { 56 | help(0); 57 | } elsif ($group eq 'p') { 58 | $fetch_value = sub { $port = shift }; 59 | } elsif ($group eq 'v') { 60 | $verbose = 1; 61 | } elsif ($group eq 'w') { 62 | $ask_for_pass = 1; 63 | } elsif ($group eq 'W') { 64 | $ask_for_pass_only_for_sudo = 1; 65 | } elsif ($group eq 'P') { 66 | $ask_for_passphrase = 1; 67 | } elsif ($group eq 'c') { 68 | $fetch_value = sub { $concurrency = shift }; 69 | } elsif ($group eq 'ssh') { 70 | $fetch_value = sub { $ssh_cmd = shift }; 71 | } elsif ($group eq 'L') { 72 | $line_mode = 1; 73 | } elsif ($group eq 'tty') { 74 | $use_tty = 1; 75 | } elsif ($group eq 'q') { 76 | $use_quiet_mode = 1; 77 | } else { 78 | die "Unknown option: $_\n"; 79 | } 80 | $last_option = $_; 81 | next; 82 | } 83 | push @exprs, $_; 84 | } 85 | 86 | if ($ask_for_pass && $ask_for_pass_only_for_sudo) { 87 | die "ERROR: Option -w should not be used together with -W.\n", 88 | "Use -w to use passowrd for login and sudo, -W for sudo only.\n"; 89 | } 90 | 91 | if (defined $fetch_value) { 92 | die "ERROR: Option $last_option takes a value.\n"; 93 | } 94 | 95 | if (!$found_sep && !@cmd) { 96 | push @cmd, shift @exprs; 97 | } 98 | if (!@cmd) { 99 | die "No command specified.\n"; 100 | } 101 | 102 | if ($verbose) { 103 | warn "Command: ", (map { "[$_]" } @cmd), "\n"; 104 | if (defined $ssh_cmd) { 105 | warn "Using SSH program [$ssh_cmd].\n"; 106 | } 107 | } 108 | 109 | check_openssh_version($ssh_cmd || 'ssh'); 110 | 111 | if ($use_tty) { 112 | $concurrency = 1; 113 | } 114 | 115 | if (!@exprs) { 116 | die "No cluster expression specified.\n"; 117 | } 118 | my $expr = join ' ', @exprs; 119 | 120 | if ($verbose) { 121 | warn "Cluster expression: $expr\n"; 122 | } 123 | 124 | SSH::Batch::ForNodes::init_rc(); 125 | my $set = SSH::Batch::ForNodes::parse_expr($expr); 126 | 127 | if ($set->is_empty) { 128 | die "No machine to be operated.\n"; 129 | } 130 | my @hosts = sort $set->elements; 131 | 132 | if ($verbose) { 133 | warn "Cluster set: @hosts\n"; 134 | } elsif ($list_hosts_only) { 135 | print "Cluster set: @hosts\n"; 136 | } 137 | 138 | if ($list_hosts_only) { 139 | exit(0); 140 | } 141 | 142 | my ($passphrase, $password); 143 | if ($ask_for_passphrase) { 144 | $passphrase = $ENV{SSH_BATCH_PASSPHRASE}; 145 | if (!$passphrase) { 146 | print STDERR "Passphrase:"; 147 | ReadMode(2); 148 | while (not defined ($passphrase = ReadLine(0))) { 149 | } 150 | ReadMode(0); 151 | print "\n"; 152 | chomp $passphrase; 153 | } 154 | if (!$passphrase) { 155 | die "No passphrase specified.\n"; 156 | } 157 | } elsif ($ask_for_pass || $ask_for_pass_only_for_sudo) { 158 | $password = $ENV{SSH_BATCH_PASSWORD}; 159 | if (!$password) { 160 | print STDERR "Password:"; 161 | ReadMode(2); 162 | while (not defined ($password = ReadLine(0))) { 163 | } 164 | ReadMode(0); 165 | print "\n"; 166 | chomp $password; 167 | } 168 | if (!$password) { 169 | die "No password specified.\n"; 170 | } 171 | } 172 | 173 | my (%conns, @pids, @outs); 174 | my %pid2host; 175 | my $active_count = 0; 176 | while (1) { 177 | last if !@hosts && !@pids; 178 | my @active_hosts; 179 | while ($active_count < $concurrency) { 180 | last if !@hosts; 181 | my $host = shift @hosts; 182 | my $login_with_password = (defined $password) && !$ask_for_pass_only_for_sudo; 183 | my $ssh = Net::OpenSSH->new( 184 | $host, 185 | async => 1, 186 | defined $timeout ? (timeout => $timeout) : (), 187 | defined $user ? (user => $user) : (), 188 | defined $port ? (port => $port) : (), 189 | defined $passphrase ? (passphrase => $passphrase) : (), 190 | $login_with_password ? (password => $password) : (), 191 | defined $ssh_cmd ? (ssh_cmd => $ssh_cmd) : (), 192 | $use_quiet_mode 193 | ? (master_opts => ["-q",], default_ssh_opts => ["-q",],) 194 | : (), 195 | ); 196 | if ($ssh->error) { 197 | if ($line_mode) { 198 | print STDERR "$host: "; 199 | } else { 200 | print "===" x 7, " $host ", "===" x 7, "\n"; 201 | } 202 | warn "ERROR: Failed to establish SSH connection: ", 203 | $ssh->error, "\n"; 204 | next; 205 | } 206 | $conns{$host} = $ssh; 207 | $active_count++; 208 | push @active_hosts, $host; 209 | } 210 | for my $host (@active_hosts) { 211 | my ($out, $outfile) = tmpnam(); 212 | my $ssh = $conns{$host}; 213 | my $pid = $ssh->system({ 214 | (defined $password? 215 | (stdin_data => "$password\n") : ()), 216 | stdout_fh => $out, 217 | stderr_to_stdout => 1, 218 | async => 1, 219 | defined $use_tty ? (tty => 1) : (), 220 | }, @cmd); 221 | #warn "PID: $pid\n"; 222 | if (!defined $pid or $pid == -1) { 223 | $active_count--; 224 | if ($line_mode) { 225 | print STDERR "$host: "; 226 | } else { 227 | print "===" x 7, " $host ", "===" x 7, "\n"; 228 | } 229 | if ($ssh->error) { 230 | warn "ERROR: ", $ssh->error, "\n"; 231 | } else { 232 | warn "ERROR: Failed to spawn command.\n"; 233 | } 234 | close $out; 235 | unlink $outfile; 236 | delete $conns{$host}; 237 | next; 238 | } 239 | push @outs, $outfile; 240 | push @pids, $pid; 241 | $pid2host{$pid} = $host; 242 | } 243 | if (@pids) { 244 | my $pid = shift @pids; 245 | my $host = delete $pid2host{$pid}; 246 | $active_count--; 247 | if (!$line_mode) { 248 | print "===" x 7, " $host ", "===" x 7, "\n"; 249 | } 250 | if (!defined $pid) { 251 | warn "ERROR: Failed to connect to host $host.\n"; 252 | delete $conns{$host}; 253 | next; 254 | } 255 | my $exit = 0; 256 | my $ret = waitpid($pid, 0); 257 | $exit = ($? >> 8); 258 | 259 | delete $conns{$host}; 260 | 261 | unless ($ret > 0) { 262 | #redo if ($! == EINTR); 263 | warn "$host: ERROR: waitpid($pid) failed: $!\n"; 264 | next; 265 | } 266 | 267 | my $outfile = shift @outs; 268 | 269 | my $in; 270 | if (!open $in, $outfile) { 271 | warn "ERROR: Can't open $outfile for reading: $!\n"; 272 | next; 273 | } 274 | while (<$in>) { 275 | chomp; 276 | if ($line_mode) { 277 | print "$host: "; 278 | } 279 | print "$_\n"; 280 | } 281 | if ($exit > 0) { 282 | if ($line_mode) { 283 | print STDERR "$host: "; 284 | } 285 | warn "Remote command returns status code $exit.\n"; 286 | } 287 | if (!$line_mode) { 288 | print "\n"; 289 | } 290 | close $in; 291 | unlink $outfile; 292 | } 293 | } 294 | 295 | ## HERE... 296 | 297 | sub help ($) { 298 | my $exit_code = shift; 299 | my $msg = <<'_EOC_'; 300 | USAGE: 301 | 302 | atnodes [OPTIONS] COMMAND... -- HOST_PATTERN... [OPTIONS] 303 | atnodes [OPTIONS] COMMAND HOST_PATTERN... [OPTIONS] 304 | 305 | OPTIONS: 306 | -c Set SSH concurrency limit. (default: 20, 307 | when -tty is on, this setting will no use) 308 | -h Print this help. 309 | -l List the hosts and do nothing else. 310 | -L Use the line-mode output format, i.e., prefixing 311 | every output line with the machine name. 312 | (could be controlled by the env SSH_BATCH_LINE_MODE) 313 | -p Port for the remote SSH service. 314 | -ssh Specify an alternate ssh program. 315 | (This overrides the SSH_BATCH_SSH_CMD environment.) 316 | -t Specify timeout for net traffic. 317 | -u User account for SSH login. 318 | -v Be verbose. 319 | -w Prompt for password (used for both login and sudo, 320 | could be privided by SSH_BATCH_PASSWORD). 321 | -W Prompt for password (just for sudo), 322 | should not be used with -w. 323 | -P Prompt for passphrase (used for login, 324 | could be privided by SSH_BATCH_PASSPHRASE). 325 | -tty Pseudo-tty. 326 | -q Run SSH in quiet mode 327 | _EOC_ 328 | if ($exit_code == 0) { 329 | print $msg; 330 | exit(0); 331 | } else { 332 | warn $msg; 333 | exit($exit_code); 334 | } 335 | } 336 | 337 | sub check_openssh_version ($) { 338 | my $ssh_cmd = shift; 339 | 340 | my $version_info = `$ssh_cmd -V 2>&1`; 341 | if ($version_info && $version_info =~ /^OpenSSH_(\d+\.\d+)/) { 342 | my $v = $1; 343 | if ($v && $v < 4.1) { 344 | die "OpenSSH version $v, should be >= 4.1!\n"; 345 | } 346 | } 347 | } 348 | 349 | __END__ 350 | 351 | =encoding utf-8 352 | 353 | =head1 NAME 354 | 355 | atnodes - Run commands on clusters 356 | 357 | =head1 SYNOPSIS 358 | 359 | # run a command on the specified servers: 360 | $ atnodes $'ps -fe|grep httpd' 'ws[1101-1105].as.com' 361 | 362 | # multiple-arg command requires "--": 363 | $ atnodes ls /opt/ -- '{ps} + {as}' 'localhost' 364 | 365 | # or use single arg command: 366 | $ atnodes 'ls /opt/' '{ps} + {as}' 'localhost' # ditto 367 | 368 | # specify a different user name and SSH server port: 369 | $ atnodes hostname '{ps}' -u agentz -p 12345 370 | 371 | # use -w to prompt for password if w/o SSH key (no echo back) 372 | $ atnodes hostname '{ps}' -u agentz -w 373 | 374 | # or prompt for password if login and sudo required... 375 | $ atnodes 'sudo apachectl restart' '{ps}' -w 376 | 377 | # or prompt for password for sudo only... 378 | $ atnodes 'sudo apachectl restart' '{ps}' -W 379 | 380 | # use -P to prompt for passphrase (no echo back) 381 | $ atnodes hostname '{ps}' -u agentz -P 382 | 383 | # run sudo command if tty required... 384 | $ atnodes -tty 'sudo apachectl restart' '{ps}' 385 | 386 | # or specify a timeout: 387 | $ atnodes 'ping foo.com' '{ps}' -t 3 388 | 389 | =head1 USAGE 390 | 391 | atnodes [OPTIONS] COMMAND... -- HOST_PATTERN... [OPTIONS] 392 | atnodes [OPTIONS] COMMAND HOST_PATTERN... [OPTIONS] 393 | 394 | =head1 OPTIONS 395 | 396 | -c Set SSH concurrency limit. (default: 20, 397 | when -tty is on, this setting will no use) 398 | -h Print this help. 399 | -l List the hosts and do nothing else. 400 | -L Use the line-mode output format, i.e., prefixing 401 | every output line with the machine name. 402 | (could be controlled by the env SSH_BATCH_LINE_MODE) 403 | -p Port for the remote SSH service. 404 | -ssh Specify an alternate ssh program. 405 | (This overrides the SSH_BATCH_SSH_CMD environment.) 406 | -t Specify timeout for net traffic. 407 | -u User account for SSH login. 408 | -v Be verbose. 409 | -w Prompt for password (used for login and sudo, 410 | could be privided by SSH_BATCH_PASSWORD). 411 | -W Prompt for password (like -w but conflict, just for sudo. 412 | Never use -W together with -w, because -w will be ignored). 413 | -P Prompt for passphrase (used for login, 414 | could be privided by SSH_BATCH_PASSPHRASE). 415 | -tty Pseudo-tty. 416 | -q Run SSH in quiet mode 417 | 418 | =head1 PREREQUISITES 419 | 420 | C (as well as the other scripts bundled by L) requires the OpenSSH I executable (usually spelled "ssh") with multiplexing support (at least OpenSSH 4.1). To check your C version, use the command: 421 | 422 | $ ssh -v 423 | 424 | On my machine, it echos 425 | 426 | OpenSSH_4.7p1 Debian-8ubuntu1.2, OpenSSL 0.9.8g 19 Oct 2007 427 | usage: ssh [-1246AaCfgKkMNnqsTtVvXxY] [-b bind_address] [-c cipher_spec] 428 | [-D [bind_address:]port] [-e escape_char] [-F configfile] 429 | [-i identity_file] [-L [bind_address:]port:host:hostport] 430 | [-l login_name] [-m mac_spec] [-O ctl_cmd] [-o option] [-p port] [-R [bind_address:]port:host:hostport] [-S ctl_path] 431 | [-w local_tun[:remote_tun]] [user@]hostname [command] 432 | 433 | There's no spesial requirement on the server side ssh service. Even a non-OpenSSH server-side deamon should work as well. 434 | 435 | =head1 DESCRIPTION 436 | 437 | Please refer to L for more documentation. 438 | 439 | =head1 SEE ALSO 440 | 441 | L, L, L, L, L. 442 | 443 | =head1 AUTHORS 444 | 445 | =over 446 | 447 | =item * 448 | 449 | Zhang "agentzh" Yichun (章亦春) C<< >> 450 | 451 | =item * 452 | 453 | Liseen Wan (万珣新) C<< >> 454 | 455 | =back 456 | 457 | =head1 COPYRIGHT & LICENSE 458 | 459 | This module as well as its programs are licensed under the BSD License. 460 | 461 | Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. 462 | 463 | Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun (章亦春). All rights reserved. 464 | 465 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 466 | 467 | =over 468 | 469 | =item * 470 | 471 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 472 | 473 | =item * 474 | 475 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 476 | 477 | =item * 478 | 479 | Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 480 | 481 | =back 482 | 483 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 484 | 485 | -------------------------------------------------------------------------------- /bin/fornodes: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | #use Smart::Comments::JSON '##'; 7 | use lib 'lib'; 8 | use SSH::Batch::ForNodes; 9 | 10 | sub help ($); 11 | 12 | SSH::Batch::ForNodes::init_rc(); 13 | 14 | my $expand_list; 15 | my @args; 16 | for (@ARGV) { 17 | if (/^-(.*)/) { 18 | my $group = $1; 19 | if ($group eq 'x') { 20 | $expand_list = 1; 21 | } elsif ($group eq 'h') { 22 | help(0); 23 | } else { 24 | die "ERROR: Unknown option $_\n"; 25 | } 26 | } else { 27 | push @args, $_; 28 | } 29 | } 30 | 31 | ## @ARGV 32 | my $expr = join ' ', @args; 33 | if (!$expr) { 34 | warn "No argument specified.\n\n"; 35 | help(1); 36 | } 37 | 38 | my $set = SSH::Batch::ForNodes::parse_expr($expr); 39 | 40 | if ($expand_list) { 41 | for my $host (sort $set->elements) { 42 | print $host, "\n"; 43 | } 44 | } else { 45 | print join(' ', sort $set->elements), "\n"; 46 | } 47 | 48 | sub help ($) { 49 | my $exit_code = shift; 50 | my $msg = <<'_EOC_'; 51 | USAGE: 52 | 53 | fornodes [OPTIONS] HOST_PATTERN... [OPTIONS] 54 | 55 | OPTIONS: 56 | -h Print this help 57 | -x Expand the host list output to multiple lines. 58 | _EOC_ 59 | if ($exit_code == 0) { 60 | print $msg; 61 | exit 0; 62 | } else { 63 | warn $msg; 64 | exit $exit_code; 65 | } 66 | } 67 | 68 | __END__ 69 | 70 | =encoding utf-8 71 | 72 | =head1 NAME 73 | 74 | fornodes - Expand patterns to machine host list 75 | 76 | =head1 SYNOPSIS 77 | 78 | $ cat > ~/.fornodesrc 79 | ps=blah.ps.com bloo.ps.com boo[2-25,32,41-70].ps.com 80 | as=ws[1101-1105].as.com 81 | # use set operations to define new sets: 82 | foo={ps} + {ps} * {as} - {ps} / {as} 83 | bar = foo.com bar.org \ 84 | bah.cn \ 85 | baz.com 86 | ^D 87 | 88 | $ fornodes 'api[02-10].foo.bar.com' 'boo*.ps.com' 89 | $ fornodes 'tq[ab-ac].[1101-1105].foo.com' 90 | $ fornodes '{ps} + {as} - ws1104.as.com' # set union and subtraction 91 | $ fornodes '{ps} * {as}' # set intersect 92 | 93 | =head1 USAGE 94 | 95 | fornodes [OPTIONS] HOST_PATTERN... [OPTIONS] 96 | 97 | =head1 OPTIONS 98 | 99 | -h Print this help 100 | -x Expand the host list output to multiple lines. 101 | 102 | =head1 DESCRIPTION 103 | 104 | Please refer to L for more documentation. 105 | 106 | =head1 AUTHORS 107 | 108 | =over 109 | 110 | =item * 111 | 112 | Zhang "agentzh" Yichun (章亦春) C<< >> 113 | 114 | =item * 115 | 116 | Liseen Wan (万珣新) C<< >> 117 | 118 | =back 119 | 120 | =head1 COPYRIGHT & LICENSE 121 | 122 | This module as well as its programs are licensed under the BSD License. 123 | 124 | Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. 125 | 126 | Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun (章亦春). 127 | 128 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 129 | 130 | =over 131 | 132 | =item * 133 | 134 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 135 | 136 | =item * 137 | 138 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 139 | 140 | =item * 141 | 142 | Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 143 | 144 | =back 145 | 146 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 147 | 148 | =head1 SEE ALSO 149 | 150 | L, L, L, L, L. 151 | 152 | -------------------------------------------------------------------------------- /bin/key2nodes: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use lib 'lib'; 7 | use Net::OpenSSH; 8 | use Term::ReadKey; 9 | use SSH::Batch::ForNodes; 10 | use File::Temp qw/ :POSIX /; 11 | use File::HomeDir; 12 | 13 | sub help ($); 14 | 15 | if (!@ARGV) { 16 | warn "No argument specified.\n\n"; 17 | help(1); 18 | } 19 | 20 | my $list_hosts_only = 0; 21 | my ($user, $port, $timeout, $verbose); 22 | my (@exprs); 23 | my $concurrency = 20; 24 | my $fetch_value; 25 | my $ssh_cmd = $ENV{SSH_BATCH_SSH_CMD}; 26 | for (@ARGV) { 27 | if (defined $fetch_value) { 28 | $fetch_value->($_); 29 | undef $fetch_value; 30 | next; 31 | } 32 | if (/^-([A-Za-z])(.*)/) { 33 | if ($2 ne '') { 34 | die "Unknown option: $_\n"; 35 | } 36 | my $group = $1; 37 | if ($group eq 'l') { 38 | $list_hosts_only = 1; 39 | } elsif ($group eq 'u') { 40 | $fetch_value = sub { $user = shift }; 41 | } elsif ($group eq 't') { 42 | $fetch_value = sub { $timeout = shift }; 43 | } elsif ($group eq 'h') { 44 | help(0); 45 | } elsif ($group eq 'p') { 46 | $fetch_value = sub { $port = shift }; 47 | } elsif ($group eq 'v') { 48 | $verbose = 1; 49 | } elsif ($group eq 'ssh') { 50 | $fetch_value = sub { $ssh_cmd = shift }; 51 | } elsif ($group eq 'c') { 52 | $fetch_value = sub { $concurrency = shift }; 53 | } else { 54 | die "Unknown option: $_\n"; 55 | } 56 | next; 57 | } 58 | push @exprs, $_; 59 | } 60 | 61 | if (!@exprs) { 62 | die "No cluster expression specified.\n"; 63 | } 64 | my $expr = join ' ', @exprs; 65 | 66 | if ($verbose) { 67 | warn "Cluster expression: $expr\n"; 68 | } 69 | 70 | my $home = $ENV{SSH_BATCH_HOME} || File::HomeDir->my_home; 71 | if (!defined $home) { 72 | die "Can't find the home for the current user.\n"; 73 | } 74 | 75 | my $pubkey_file = "$home/.ssh/id_rsa.pub"; 76 | if (-f $pubkey_file) { 77 | if ($verbose) { 78 | warn "Found public key file $pubkey_file.\n"; 79 | } 80 | } else { 81 | my $cmd = "(echo; echo y; echo; echo) | ssh-keygen -q -t rsa"; 82 | if ($verbose) { 83 | warn "Running command [$cmd]...\n"; 84 | } 85 | if (system($cmd) != 0) { 86 | die "Generating SSH key failed.\n"; 87 | } 88 | } 89 | 90 | open my $in, $pubkey_file or 91 | die "Can't open $pubkey_file for reading: $!\n"; 92 | my $pubkey = do { local $/; <$in> }; 93 | close $in; 94 | 95 | SSH::Batch::ForNodes::init_rc(); 96 | my $set = SSH::Batch::ForNodes::parse_expr($expr); 97 | 98 | if ($set->is_empty) { 99 | die "No machine to be operated.\n"; 100 | } 101 | my @hosts = sort $set->elements; 102 | 103 | if ($verbose) { 104 | warn "Cluster set: @hosts\n"; 105 | } elsif ($list_hosts_only) { 106 | print "Cluster set: @hosts\n"; 107 | } 108 | 109 | if ($list_hosts_only) { 110 | exit(0); 111 | } 112 | 113 | my $password; 114 | print STDERR "Password:"; 115 | ReadMode(2); 116 | while (not defined ($password = ReadLine(0))) { 117 | } 118 | ReadMode(0); 119 | print "\n"; 120 | chomp $password; 121 | if (!$password) { 122 | die "No password specified.\n"; 123 | } 124 | 125 | my (%conns, @pids, @outs); 126 | my %pid2host; 127 | my $active_count = 0; 128 | while (1) { 129 | last if !@hosts && !@pids; 130 | my @active_hosts; 131 | while ($active_count < $concurrency) { 132 | last if !@hosts; 133 | my $host = shift @hosts; 134 | $active_count++; 135 | my $ssh = Net::OpenSSH->new( 136 | $host, 137 | async => 1, 138 | defined $timeout ? (timeout => $timeout) : (), 139 | defined $user ? (user => $user) : (), 140 | defined $port ? (port => $port) : (), 141 | password => $password, 142 | defined $ssh_cmd ? (ssh_cmd => $ssh_cmd) : (), 143 | master_opts => [-o => "StrictHostKeyChecking no"], 144 | ); 145 | if ($ssh->error) { 146 | print "===" x 7, " $host ", "===" x 7, "\n"; 147 | warn "ERROR: Failed to establish SSH connection: ", 148 | $ssh->error, "\n"; 149 | next; 150 | } 151 | $conns{$host} = $ssh; 152 | $active_count++; 153 | push @active_hosts, $host; 154 | } 155 | 156 | for my $host (@active_hosts) { 157 | my ($out, $outfile) = tmpnam(); 158 | my $ssh = $conns{$host}; 159 | my $pid = $ssh->system({ 160 | stdin_data => $pubkey, 161 | stdout_fh => $out, 162 | stderr_to_stdout => 1, 163 | async => 1, 164 | #tty => 1, 165 | }, 'if [ ! -d ~/.ssh ]; then mkdir ~/.ssh; fi; chmod 700 ~/.ssh; cat >> ~/.ssh/authorized_keys && chmod 640 ~/.ssh/authorized_keys'); 166 | if (!defined $pid or $pid == -1) { 167 | $active_count--; 168 | print "===" x 7, " $host ", "===" x 7, "\n"; 169 | warn "Failed to spawn command.\n\n"; 170 | if ($ssh->error) { 171 | warn "ERROR: ", $ssh->error, "\n"; 172 | } else { 173 | warn "ERROR: Failed to spawn command.\n"; 174 | } 175 | close $out; 176 | unlink $outfile; 177 | delete $conns{$host}; 178 | next; 179 | } 180 | push @outs, $outfile; 181 | push @pids, $pid; 182 | $pid2host{$pid} = $host; 183 | } 184 | 185 | ## HERE... 186 | 187 | if (@pids) { 188 | my $pid = shift @pids; 189 | my $host = delete $pid2host{$pid}; 190 | $active_count--; 191 | print "===" x 7, " $host ", "===" x 7, "\n"; 192 | if (!defined $pid) { 193 | warn "Failed to connect to host $host.\n"; 194 | delete $conns{$host}; 195 | next; 196 | } 197 | my $exit = 0; 198 | my $ret = waitpid($pid, 0); 199 | if ($ret > 0) { 200 | $exit = ($? >> 8); 201 | } else { 202 | #redo if ($! == EINTR); 203 | warn "$host: waitpid($pid) failed: $!\n"; 204 | delete $conns{$host}; 205 | next; 206 | } 207 | 208 | delete $conns{$host}; 209 | 210 | my $outfile = shift @outs; 211 | 212 | my $in; 213 | if (!open $in, $outfile) { 214 | warn "Can't open $outfile for reading: $!\n"; 215 | next; 216 | } 217 | while (<$in>) { 218 | print; 219 | } 220 | if ($exit > 0) { 221 | warn "Remote command returns status code $exit.\n"; 222 | } 223 | print "\n"; 224 | close $in; 225 | } 226 | } 227 | 228 | sub help ($) { 229 | my $exit_code = shift; 230 | my $msg = <<'_EOC_'; 231 | USAGE: 232 | 233 | key2nodes [OPTIONS] HOST_PATTERN... [OPTIONS] 234 | 235 | OPTIONS: 236 | -c Set SSH concurrency limit. (default: 20) 237 | -h Print this help. 238 | -l List the hosts and do nothing else. 239 | -p Port for the remote SSH service. 240 | -ssh Specify an alternate ssh program. 241 | (This overrides the SSH_BATCH_SSH_CMD environment.) 242 | -t Specify timeout for net traffic. 243 | -u User account for SSH login. 244 | -v Be verbose. 245 | _EOC_ 246 | if ($exit_code == 0) { 247 | print $msg; 248 | exit(0); 249 | } else { 250 | warn $msg; 251 | exit($exit_code); 252 | } 253 | } 254 | __END__ 255 | 256 | =encoding utf-8 257 | 258 | =head1 NAME 259 | 260 | key2nodes - Push SSH public keys to remote clusters 261 | 262 | =head1 SYNOPSIS 263 | 264 | # push SSH public keys to remote clusters 265 | $ key2nodes 'ws[1101-1105].as.com' 266 | 267 | $ cat > ~/.fornodesrc 268 | office=blah.ps.com bloo.ps.com boo[2-25,32,41-70].ps.com 269 | 270 | $ key2nodes '{office}' # reference cluster var defined 271 | # in ~/.fornodesrc 272 | 273 | =head1 USAGE 274 | 275 | key2nodes [OPTIONS] HOST_PATTERN... [OPTIONS] 276 | 277 | =head1 OPTIONS 278 | 279 | -c Set SSH concurrency limit. (default: 20) 280 | -h Print this help. 281 | -l List the hosts and do nothing else. 282 | -p Port for the remote SSH service. 283 | -ssh Specify an alternate ssh program. 284 | (This overrides the SSH_BATCH_SSH_CMD environment.) 285 | -t Specify timeout for net traffic. 286 | -u User account for SSH login. 287 | -v Be verbose. 288 | 289 | =head1 DESCRIPTION 290 | 291 | This script push local F<~/.ssh/id_rsa.pub> file (i.e. the SSH public key) onto the remote server's F<~/.ssh/authorized_keys>. It will chmod F<.ssh> to C<700> and F<.ssh/authorized_keys> to C<640>. 292 | 293 | If there's no .ssh directory on the remote server, it will try to create one. 294 | 295 | Note that the sh/bash shell is assumed on the remote machines. 296 | 297 | When no F<~/.ssh/id_rsa.pub> file found on the local machine, it will invoke 298 | C automatically. 299 | 300 | =head1 SEE ALSO 301 | 302 | L, L, L, L, L. 303 | 304 | =head1 COPYRIGHT AND LICENSE 305 | 306 | This module as well as its programs are licensed under the BSD License. 307 | 308 | Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. 309 | 310 | Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun (章亦春). All rights reserved. 311 | 312 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 313 | 314 | =over 315 | 316 | =item * 317 | 318 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 319 | 320 | =item * 321 | 322 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 323 | 324 | =item * 325 | 326 | Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 327 | 328 | =back 329 | 330 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 331 | 332 | -------------------------------------------------------------------------------- /bin/tonodes: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | #use Smart::Comments::JSON '##'; 7 | use lib 'lib'; 8 | use Net::OpenSSH; 9 | use Term::ReadKey; 10 | use SSH::Batch::ForNodes; 11 | use File::Temp qw/ :POSIX /; 12 | 13 | sub help ($); 14 | 15 | if (!@ARGV) { 16 | warn "No argument specified.\n\n"; 17 | help(1); 18 | } 19 | 20 | my $list_hosts_only = 0; 21 | my ($user, $port, $timeout, $verbose, $ask_for_pass, $ask_for_passphrase, $recursive, $use_glob); 22 | my ($bwlimit, $use_rsync); 23 | my $concurrency = 20; 24 | my (@files, @exprs); 25 | my $fetch_value; 26 | my $found_sep; 27 | my $last_option; 28 | my $line_mode = $ENV{SSH_BATCH_LINE_MODE}; 29 | 30 | my $rsync_archive; 31 | my $rsync_update; 32 | my $rsync_compress; 33 | 34 | for (@ARGV) { 35 | if (defined $fetch_value) { 36 | $fetch_value->($_); 37 | undef $fetch_value; 38 | next; 39 | } 40 | if ($_ eq '--') { 41 | @files = @exprs; 42 | @exprs = (); 43 | $found_sep = 1; 44 | next; 45 | } 46 | if (/^-(.+)/) { 47 | my $group = $1; 48 | if ($group eq 'l') { 49 | $list_hosts_only = 1; 50 | } elsif ($group eq 'u') { 51 | $fetch_value = sub { $user = shift }; 52 | } elsif ($group eq 't') { 53 | $fetch_value = sub { $timeout = shift }; 54 | } elsif ($group eq 'h') { 55 | help(0); 56 | } elsif ($group eq 'p') { 57 | $fetch_value = sub { $port = shift }; 58 | } elsif ($group eq 'v') { 59 | $verbose = 1; 60 | } elsif ($group eq 'w') { 61 | $ask_for_pass = 1; 62 | } elsif ($group eq 'P') { 63 | $ask_for_passphrase = 1; 64 | } elsif ($group eq 'r') { 65 | $recursive = 1; 66 | } elsif ($group eq 'g') { 67 | $use_glob = 1; 68 | } elsif ($group eq 'b') { 69 | $fetch_value = sub { $bwlimit = shift }; 70 | } elsif ($group eq 'rsync') { 71 | $use_rsync = 1; 72 | } elsif ($group eq 'archive') { 73 | $rsync_archive = 1; 74 | } elsif ($group eq 'update') { 75 | $rsync_update = 1; 76 | } elsif ($group eq 'compress') { 77 | $rsync_compress = 1; 78 | } elsif ($group eq 'c') { 79 | $fetch_value = sub { $concurrency = shift }; 80 | } elsif ($group eq 'L') { 81 | $line_mode = 1; 82 | } else { 83 | die "Unknown option: $_\n"; 84 | } 85 | $last_option = $_; 86 | next; 87 | } 88 | push @exprs, $_; 89 | } 90 | if (defined $fetch_value) { 91 | die "ERROR: Option $last_option takes a value.\n"; 92 | } 93 | 94 | if (!$found_sep && !@files) { 95 | push @files, shift @exprs; 96 | } 97 | if (!@files) { 98 | die "No local files/directories specified.\n"; 99 | } 100 | 101 | if ($use_glob) { 102 | @files = map glob, @files; 103 | } 104 | 105 | my $changed = 0; 106 | for my $file (@files) { 107 | if (!-e $file) { 108 | die "Local file/directory $file not found.\n"; 109 | } 110 | if (!$recursive && -d $file) { 111 | warn "Warning: Skipped directory $file.\n"; 112 | undef $file; 113 | $changed = 1; 114 | } 115 | } 116 | 117 | if ($changed) { 118 | @files = grep { defined $_ } @files; 119 | if (!@files) { 120 | die "ERROR: No files to be transferred.\n"; 121 | } 122 | } 123 | 124 | if ($verbose) { 125 | warn "Using ", $use_rsync ? 'Rsync' : 'Scp', " method.\n"; 126 | warn "Local files: ", (map { "[$_]" } @files), "\n"; 127 | } 128 | 129 | my $expr = join ' ', @exprs; 130 | my $target_path; 131 | if ($expr =~ s/\s*:(\D\S*)\s*$//) { 132 | $target_path = $1; 133 | } else { 134 | die "No remote target path specified.\n", 135 | " (You forgot to specify \":/path/to/target\" at the end of the command line?)\n"; 136 | } 137 | my $expanded_path = 0; 138 | if (defined $ENV{USER}) { 139 | my $old_target = $target_path; 140 | # XXX FIXME Maybe we should expand ~ on the remote server? 141 | if ($target_path =~ s{^~(/|$)}{/home/$ENV{USER}$1}) { 142 | warn "WARNING: Expanding target path $old_target to $target_path\n"; 143 | $expanded_path = 1; 144 | } 145 | } 146 | if (!$expanded_path) { 147 | my $old_target = $target_path; 148 | if ($target_path =~ s{^~(\w+)}{/home/$1}) { 149 | warn "WARNING: Expanding target path $old_target to $target_path\n"; 150 | $expanded_path = 1; 151 | } 152 | } 153 | 154 | if ($expr =~ /^\s*$/) { 155 | die "No cluster expression specified.\n"; 156 | } 157 | 158 | if ($verbose) { 159 | warn "Cluster expression: $expr\n"; 160 | warn "Target path: ", defined $target_path ? $target_path : '', "\n"; 161 | } 162 | 163 | SSH::Batch::ForNodes::init_rc(); 164 | my $set = SSH::Batch::ForNodes::parse_expr($expr); 165 | 166 | if ($set->is_empty) { 167 | die "No machine to be operated.\n"; 168 | } 169 | my @hosts = sort $set->elements; 170 | 171 | if ($verbose) { 172 | warn "Cluster set: @hosts\n"; 173 | } elsif ($list_hosts_only) { 174 | print "Cluster set: @hosts\n"; 175 | } 176 | 177 | if ($list_hosts_only) { 178 | exit(0); 179 | } 180 | my ($passphrase, $password); 181 | if ($ask_for_passphrase) { 182 | $passphrase = $ENV{SSH_BATCH_PASSPHRASE}; 183 | if (!$passphrase) { 184 | print STDERR "Passphrase:"; 185 | ReadMode(2); 186 | while (not defined ($passphrase = ReadLine(0))) { 187 | } 188 | ReadMode(0); 189 | print "\n"; 190 | chomp $passphrase; 191 | } 192 | if (!$passphrase) { 193 | die "No passphrase specified.\n"; 194 | } 195 | } elsif ($ask_for_pass) { 196 | $password = $ENV{SSH_BATCH_PASSWORD}; 197 | if (!$password) { 198 | print STDERR "Password:"; 199 | ReadMode(2); 200 | while (not defined ($password = ReadLine(0))) { 201 | } 202 | ReadMode(0); 203 | print "\n"; 204 | chomp $password; 205 | } 206 | if (!$password) { 207 | die "No password specified.\n"; 208 | } 209 | } 210 | 211 | my (%conns, @pids, @outs); 212 | my %pid2host; 213 | my $active_count = 0; 214 | while (1) { 215 | last if !@hosts && !@pids; 216 | my @active_hosts; 217 | while ($active_count < $concurrency) { 218 | last if !@hosts; 219 | my $host = shift @hosts; 220 | ## connecting to host: $host 221 | my $ssh = Net::OpenSSH->new( 222 | $host, 223 | async => 1, 224 | defined $timeout ? (timeout => $timeout) : (), 225 | defined $user ? (user => $user) : (), 226 | defined $port ? (port => $port) : (), 227 | defined $passphrase ? (passphrase => $passphrase) : (), 228 | defined $password ? (password => $password) : (), 229 | ); 230 | if ($ssh->error) { 231 | if ($line_mode) { 232 | print STDERR "$host: "; 233 | } else { 234 | print "===" x 7, " $host ", "===" x 7, "\n"; 235 | } 236 | warn "ERROR: Failed to establish SSH connection: ", 237 | $ssh->error, "\n"; 238 | next; 239 | } 240 | $conns{$host} = $ssh; 241 | $active_count++; 242 | push @active_hosts, $host; 243 | } 244 | for my $host (@active_hosts) { 245 | my ($out, $outfile) = tmpnam(); 246 | my $meth = $use_rsync ? 'rsync_put' : 'scp_put'; 247 | 248 | ## starting transfer to host: $host 249 | my $ssh = $conns{$host}; 250 | my $pid = $ssh->$meth({ 251 | stdout_fh => $out, 252 | stderr_to_stdout => 1, 253 | async => 1, 254 | defined $recursive ? (recursive => $recursive) : (), 255 | defined $bwlimit ? (bwlimit => $bwlimit) : (), 256 | 257 | defined $use_rsync && defined $rsync_archive ? (archive => 1) : (), 258 | defined $use_rsync && defined $rsync_update ? (update => 1) : (), 259 | defined $use_rsync && defined $rsync_compress ? (compress => 1) : (), 260 | # XXX recursive 261 | }, @files, $target_path); 262 | if (!defined $pid or $pid == -1) { 263 | $active_count--; 264 | if ($line_mode) { 265 | print STDERR "$host: "; 266 | } else { 267 | print "===" x 7, " $host ", "===" x 7, "\n"; 268 | } 269 | if ($ssh->error) { 270 | warn "ERROR: ", $ssh->error, "\n"; 271 | } else { 272 | warn "ERROR: Failed to transfer files.\n"; 273 | } 274 | close $out; 275 | unlink $outfile; 276 | delete $conns{$host}; 277 | next; 278 | } 279 | push @outs, $outfile; 280 | push @pids, $pid; 281 | $pid2host{$pid} = $host; 282 | } 283 | if (@pids) { 284 | my $pid = shift @pids; 285 | my $host = delete $pid2host{$pid}; 286 | $active_count--; 287 | ## waiting transfer to host: $host 288 | if (!$line_mode) { 289 | print "===" x 7, " $host ", "===" x 7, "\n"; 290 | } 291 | if (!defined $pid) { 292 | warn "Failed to connect to host $host.\n"; 293 | delete $conns{$host}; 294 | next; 295 | } 296 | my $ret = waitpid($pid, 0); 297 | my $exit = ($? >> 8); 298 | 299 | delete $conns{$host}; 300 | 301 | if ($ret > 0) { 302 | if ($exit > 0) { 303 | warn "$host: Transfer of files failed (status code: $exit)\n"; 304 | next; 305 | } 306 | } else { 307 | #redo if ($! == EINTR); 308 | if ($line_mode) { 309 | print STDERR "$host: "; 310 | } 311 | warn "$host: waitpid($pid) failed: $!\n"; 312 | next; 313 | } 314 | my $outfile = shift @outs; 315 | my $in; 316 | if (!open $in, $outfile) { 317 | if ($line_mode) { 318 | print STDERR "$host: "; 319 | } 320 | warn "Can't open $outfile for reading: $!\n"; 321 | next; 322 | } 323 | while (<$in>) { 324 | chomp; 325 | if ($line_mode) { 326 | print "$host: "; 327 | } 328 | print "$_\n"; 329 | } 330 | if (!$line_mode) { 331 | print "\n"; 332 | } 333 | close $in; 334 | } 335 | } 336 | 337 | sub help ($) { 338 | my $exit_code = shift; 339 | my $msg = <<'_EOC_'; 340 | USAGE: 341 | 342 | tonodes [OPTIONS] FILE... -- HOST_PATTERN... [OPTIONS] 343 | tonodes [OPTIONS] FILE HOST_PATTERN... [OPTIONS] 344 | 345 | OPTIONS: 346 | -c Set SSH concurrency limit. (default: 20) 347 | -b bandwidth limit in Kbits/sec. 348 | -g Use glob to process the input files/directories. 349 | -h Print this help. 350 | -l List the hosts and do nothing else. 351 | -L Use the line-mode output format, i.e., prefixing 352 | every output line with the machine name. 353 | (could be controlled by the env SSH_BATCH_LINE_MODE) 354 | -p Port for the remote SSH service. 355 | -r Recurse into directories too. 356 | -rsync Use "rsync" to transfer files. 357 | -archive Enable rsync archive mode 358 | -update Enable rsync update 359 | -compress Enable rsync compress 360 | -t Specify timeout for net traffic. 361 | -u User account for SSH login. 362 | -v Be verbose. 363 | -w Prompt for password (used mostly for login and sudo, 364 | could be privided by SSH_BATCH_PASSWORD). 365 | -P Prompt for passphrase (used mostly for login, 366 | could be privided by SSH_BATCH_PASSPHRASE). 367 | _EOC_ 368 | if ($exit_code == 0) { 369 | print $msg; 370 | exit(0); 371 | } else { 372 | warn $msg; 373 | exit($exit_code); 374 | } 375 | } 376 | __END__ 377 | 378 | =encoding utf-8 379 | 380 | =head1 NAME 381 | 382 | tonodes - Upload local files/directories to remote clusters 383 | 384 | =head1 SYNOPSIS 385 | 386 | # tonodes calls fornodes internally... 387 | 388 | $ tonodes /tmp/*.inst -- '{as}:/tmp/' 389 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt 390 | 391 | $ tonodes -r /opt /bin/* -- 'ws[1101-1102].foo.com' 'bar.com' :/foo/bar/ 392 | 393 | # use rsync instead of scp: 394 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync 395 | 396 | # use rsync archive update compress 397 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync -archive -update -compress 398 | 399 | 400 | =head1 USAGE 401 | 402 | tonodes [OPTIONS] FILE... -- HOST_PATTERN... [OPTIONS] 403 | tonodes [OPTIONS] FILE HOST_PATTERN... [OPTIONS] 404 | 405 | =head1 OPTIONS 406 | 407 | -c Set SSH concurrency limit. (default: 20) 408 | -b bandwidth limit in Kbits/sec. 409 | -g Use glob to process the input files/directories. 410 | -h Print this help. 411 | -l List the hosts and do nothing else. 412 | -L Use the line-mode output format, i.e., prefixing 413 | every output line with the machine name. 414 | (could be controlled by the env SSH_BATCH_LINE_MODE) 415 | -p Port for the remote SSH service. 416 | -r Recurse into directories too. 417 | -rsync Use "rsync" to transfer files. 418 | -archive Enable rsync archive mode 419 | -update Enable rsync update 420 | -compress Enable rsync compress 421 | -t Specify timeout for net traffic. 422 | -u User account for SSH login. 423 | -v Be verbose. 424 | -w Prompt for password (used mostly for login and sudo, 425 | could be privided by SSH_BATCH_PASSWORD). 426 | -P Prompt for passphrase (used mostly for login, 427 | could be privided by SSH_BATCH_PASSPHRASE). 428 | 429 | =head1 DESCRIPTION 430 | 431 | Please refer to L for more documentation. 432 | 433 | =head1 AUTHORS 434 | 435 | =over 436 | 437 | =item * 438 | 439 | Zhang "agentzh" Yichun (章亦春) C<< >> 440 | 441 | =item * 442 | 443 | Liseen Wan (万珣新) C<< >> 444 | 445 | =back 446 | 447 | =head1 COPYRIGHT & LICENSE 448 | 449 | This module as well as its programs are licensed under the BSD License. 450 | 451 | Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. 452 | 453 | Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun. All rights reserved. 454 | 455 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 456 | 457 | =over 458 | 459 | =item * 460 | 461 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 462 | 463 | =item * 464 | 465 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 466 | 467 | =item * 468 | 469 | Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 470 | 471 | =back 472 | 473 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 474 | 475 | =head1 SEE ALSO 476 | 477 | L, L, L, L, L. 478 | 479 | -------------------------------------------------------------------------------- /inc/Module/Install.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install; 3 | 4 | # For any maintainers: 5 | # The load order for Module::Install is a bit magic. 6 | # It goes something like this... 7 | # 8 | # IF ( host has Module::Install installed, creating author mode ) { 9 | # 1. Makefile.PL calls "use inc::Module::Install" 10 | # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install 11 | # 3. The installed version of inc::Module::Install loads 12 | # 4. inc::Module::Install calls "require Module::Install" 13 | # 5. The ./inc/ version of Module::Install loads 14 | # } ELSE { 15 | # 1. Makefile.PL calls "use inc::Module::Install" 16 | # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install 17 | # 3. The ./inc/ version of Module::Install loads 18 | # } 19 | 20 | use 5.006; 21 | use strict 'vars'; 22 | use Cwd (); 23 | use File::Find (); 24 | use File::Path (); 25 | 26 | use vars qw{$VERSION $MAIN}; 27 | BEGIN { 28 | # All Module::Install core packages now require synchronised versions. 29 | # This will be used to ensure we don't accidentally load old or 30 | # different versions of modules. 31 | # This is not enforced yet, but will be some time in the next few 32 | # releases once we can make sure it won't clash with custom 33 | # Module::Install extensions. 34 | $VERSION = '1.14'; 35 | 36 | # Storage for the pseudo-singleton 37 | $MAIN = undef; 38 | 39 | *inc::Module::Install::VERSION = *VERSION; 40 | @inc::Module::Install::ISA = __PACKAGE__; 41 | 42 | } 43 | 44 | sub import { 45 | my $class = shift; 46 | my $self = $class->new(@_); 47 | my $who = $self->_caller; 48 | 49 | #------------------------------------------------------------- 50 | # all of the following checks should be included in import(), 51 | # to allow "eval 'require Module::Install; 1' to test 52 | # installation of Module::Install. (RT #51267) 53 | #------------------------------------------------------------- 54 | 55 | # Whether or not inc::Module::Install is actually loaded, the 56 | # $INC{inc/Module/Install.pm} is what will still get set as long as 57 | # the caller loaded module this in the documented manner. 58 | # If not set, the caller may NOT have loaded the bundled version, and thus 59 | # they may not have a MI version that works with the Makefile.PL. This would 60 | # result in false errors or unexpected behaviour. And we don't want that. 61 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 62 | unless ( $INC{$file} ) { die <<"END_DIE" } 63 | 64 | Please invoke ${\__PACKAGE__} with: 65 | 66 | use inc::${\__PACKAGE__}; 67 | 68 | not: 69 | 70 | use ${\__PACKAGE__}; 71 | 72 | END_DIE 73 | 74 | # This reportedly fixes a rare Win32 UTC file time issue, but 75 | # as this is a non-cross-platform XS module not in the core, 76 | # we shouldn't really depend on it. See RT #24194 for detail. 77 | # (Also, this module only supports Perl 5.6 and above). 78 | eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; 79 | 80 | # If the script that is loading Module::Install is from the future, 81 | # then make will detect this and cause it to re-run over and over 82 | # again. This is bad. Rather than taking action to touch it (which 83 | # is unreliable on some platforms and requires write permissions) 84 | # for now we should catch this and refuse to run. 85 | if ( -f $0 ) { 86 | my $s = (stat($0))[9]; 87 | 88 | # If the modification time is only slightly in the future, 89 | # sleep briefly to remove the problem. 90 | my $a = $s - time; 91 | if ( $a > 0 and $a < 5 ) { sleep 5 } 92 | 93 | # Too far in the future, throw an error. 94 | my $t = time; 95 | if ( $s > $t ) { die <<"END_DIE" } 96 | 97 | Your installer $0 has a modification time in the future ($s > $t). 98 | 99 | This is known to create infinite loops in make. 100 | 101 | Please correct this, then run $0 again. 102 | 103 | END_DIE 104 | } 105 | 106 | 107 | # Build.PL was formerly supported, but no longer is due to excessive 108 | # difficulty in implementing every single feature twice. 109 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } 110 | 111 | Module::Install no longer supports Build.PL. 112 | 113 | It was impossible to maintain duel backends, and has been deprecated. 114 | 115 | Please remove all Build.PL files and only use the Makefile.PL installer. 116 | 117 | END_DIE 118 | 119 | #------------------------------------------------------------- 120 | 121 | # To save some more typing in Module::Install installers, every... 122 | # use inc::Module::Install 123 | # ...also acts as an implicit use strict. 124 | $^H |= strict::bits(qw(refs subs vars)); 125 | 126 | #------------------------------------------------------------- 127 | 128 | unless ( -f $self->{file} ) { 129 | foreach my $key (keys %INC) { 130 | delete $INC{$key} if $key =~ /Module\/Install/; 131 | } 132 | 133 | local $^W; 134 | require "$self->{path}/$self->{dispatch}.pm"; 135 | File::Path::mkpath("$self->{prefix}/$self->{author}"); 136 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 137 | $self->{admin}->init; 138 | @_ = ($class, _self => $self); 139 | goto &{"$self->{name}::import"}; 140 | } 141 | 142 | local $^W; 143 | *{"${who}::AUTOLOAD"} = $self->autoload; 144 | $self->preload; 145 | 146 | # Unregister loader and worker packages so subdirs can use them again 147 | delete $INC{'inc/Module/Install.pm'}; 148 | delete $INC{'Module/Install.pm'}; 149 | 150 | # Save to the singleton 151 | $MAIN = $self; 152 | 153 | return 1; 154 | } 155 | 156 | sub autoload { 157 | my $self = shift; 158 | my $who = $self->_caller; 159 | my $cwd = Cwd::getcwd(); 160 | my $sym = "${who}::AUTOLOAD"; 161 | $sym->{$cwd} = sub { 162 | my $pwd = Cwd::getcwd(); 163 | if ( my $code = $sym->{$pwd} ) { 164 | # Delegate back to parent dirs 165 | goto &$code unless $cwd eq $pwd; 166 | } 167 | unless ($$sym =~ s/([^:]+)$//) { 168 | # XXX: it looks like we can't retrieve the missing function 169 | # via $$sym (usually $main::AUTOLOAD) in this case. 170 | # I'm still wondering if we should slurp Makefile.PL to 171 | # get some context or not ... 172 | my ($package, $file, $line) = caller; 173 | die <<"EOT"; 174 | Unknown function is found at $file line $line. 175 | Execution of $file aborted due to runtime errors. 176 | 177 | If you're a contributor to a project, you may need to install 178 | some Module::Install extensions from CPAN (or other repository). 179 | If you're a user of a module, please contact the author. 180 | EOT 181 | } 182 | my $method = $1; 183 | if ( uc($method) eq $method ) { 184 | # Do nothing 185 | return; 186 | } elsif ( $method =~ /^_/ and $self->can($method) ) { 187 | # Dispatch to the root M:I class 188 | return $self->$method(@_); 189 | } 190 | 191 | # Dispatch to the appropriate plugin 192 | unshift @_, ( $self, $1 ); 193 | goto &{$self->can('call')}; 194 | }; 195 | } 196 | 197 | sub preload { 198 | my $self = shift; 199 | unless ( $self->{extensions} ) { 200 | $self->load_extensions( 201 | "$self->{prefix}/$self->{path}", $self 202 | ); 203 | } 204 | 205 | my @exts = @{$self->{extensions}}; 206 | unless ( @exts ) { 207 | @exts = $self->{admin}->load_all_extensions; 208 | } 209 | 210 | my %seen; 211 | foreach my $obj ( @exts ) { 212 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { 213 | next unless $obj->can($method); 214 | next if $method =~ /^_/; 215 | next if $method eq uc($method); 216 | $seen{$method}++; 217 | } 218 | } 219 | 220 | my $who = $self->_caller; 221 | foreach my $name ( sort keys %seen ) { 222 | local $^W; 223 | *{"${who}::$name"} = sub { 224 | ${"${who}::AUTOLOAD"} = "${who}::$name"; 225 | goto &{"${who}::AUTOLOAD"}; 226 | }; 227 | } 228 | } 229 | 230 | sub new { 231 | my ($class, %args) = @_; 232 | 233 | delete $INC{'FindBin.pm'}; 234 | { 235 | # to suppress the redefine warning 236 | local $SIG{__WARN__} = sub {}; 237 | require FindBin; 238 | } 239 | 240 | # ignore the prefix on extension modules built from top level. 241 | my $base_path = Cwd::abs_path($FindBin::Bin); 242 | unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { 243 | delete $args{prefix}; 244 | } 245 | return $args{_self} if $args{_self}; 246 | 247 | $args{dispatch} ||= 'Admin'; 248 | $args{prefix} ||= 'inc'; 249 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 250 | $args{bundle} ||= 'inc/BUNDLES'; 251 | $args{base} ||= $base_path; 252 | $class =~ s/^\Q$args{prefix}\E:://; 253 | $args{name} ||= $class; 254 | $args{version} ||= $class->VERSION; 255 | unless ( $args{path} ) { 256 | $args{path} = $args{name}; 257 | $args{path} =~ s!::!/!g; 258 | } 259 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 260 | $args{wrote} = 0; 261 | 262 | bless( \%args, $class ); 263 | } 264 | 265 | sub call { 266 | my ($self, $method) = @_; 267 | my $obj = $self->load($method) or return; 268 | splice(@_, 0, 2, $obj); 269 | goto &{$obj->can($method)}; 270 | } 271 | 272 | sub load { 273 | my ($self, $method) = @_; 274 | 275 | $self->load_extensions( 276 | "$self->{prefix}/$self->{path}", $self 277 | ) unless $self->{extensions}; 278 | 279 | foreach my $obj (@{$self->{extensions}}) { 280 | return $obj if $obj->can($method); 281 | } 282 | 283 | my $admin = $self->{admin} or die <<"END_DIE"; 284 | The '$method' method does not exist in the '$self->{prefix}' path! 285 | Please remove the '$self->{prefix}' directory and run $0 again to load it. 286 | END_DIE 287 | 288 | my $obj = $admin->load($method, 1); 289 | push @{$self->{extensions}}, $obj; 290 | 291 | $obj; 292 | } 293 | 294 | sub load_extensions { 295 | my ($self, $path, $top) = @_; 296 | 297 | my $should_reload = 0; 298 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 299 | unshift @INC, $self->{prefix}; 300 | $should_reload = 1; 301 | } 302 | 303 | foreach my $rv ( $self->find_extensions($path) ) { 304 | my ($file, $pkg) = @{$rv}; 305 | next if $self->{pathnames}{$pkg}; 306 | 307 | local $@; 308 | my $new = eval { local $^W; require $file; $pkg->can('new') }; 309 | unless ( $new ) { 310 | warn $@ if $@; 311 | next; 312 | } 313 | $self->{pathnames}{$pkg} = 314 | $should_reload ? delete $INC{$file} : $INC{$file}; 315 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 316 | } 317 | 318 | $self->{extensions} ||= []; 319 | } 320 | 321 | sub find_extensions { 322 | my ($self, $path) = @_; 323 | 324 | my @found; 325 | File::Find::find( sub { 326 | my $file = $File::Find::name; 327 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 328 | my $subpath = $1; 329 | return if lc($subpath) eq lc($self->{dispatch}); 330 | 331 | $file = "$self->{path}/$subpath.pm"; 332 | my $pkg = "$self->{name}::$subpath"; 333 | $pkg =~ s!/!::!g; 334 | 335 | # If we have a mixed-case package name, assume case has been preserved 336 | # correctly. Otherwise, root through the file to locate the case-preserved 337 | # version of the package name. 338 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 339 | my $content = Module::Install::_read($subpath . '.pm'); 340 | my $in_pod = 0; 341 | foreach ( split /\n/, $content ) { 342 | $in_pod = 1 if /^=\w/; 343 | $in_pod = 0 if /^=cut/; 344 | next if ($in_pod || /^=cut/); # skip pod text 345 | next if /^\s*#/; # and comments 346 | if ( m/^\s*package\s+($pkg)\s*;/i ) { 347 | $pkg = $1; 348 | last; 349 | } 350 | } 351 | } 352 | 353 | push @found, [ $file, $pkg ]; 354 | }, $path ) if -d $path; 355 | 356 | @found; 357 | } 358 | 359 | 360 | 361 | 362 | 363 | ##################################################################### 364 | # Common Utility Functions 365 | 366 | sub _caller { 367 | my $depth = 0; 368 | my $call = caller($depth); 369 | while ( $call eq __PACKAGE__ ) { 370 | $depth++; 371 | $call = caller($depth); 372 | } 373 | return $call; 374 | } 375 | 376 | # Done in evals to avoid confusing Perl::MinimumVersion 377 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 378 | sub _read { 379 | local *FH; 380 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 381 | binmode FH; 382 | my $string = do { local $/; }; 383 | close FH or die "close($_[0]): $!"; 384 | return $string; 385 | } 386 | END_NEW 387 | sub _read { 388 | local *FH; 389 | open( FH, "< $_[0]" ) or die "open($_[0]): $!"; 390 | binmode FH; 391 | my $string = do { local $/; }; 392 | close FH or die "close($_[0]): $!"; 393 | return $string; 394 | } 395 | END_OLD 396 | 397 | sub _readperl { 398 | my $string = Module::Install::_read($_[0]); 399 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 400 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 401 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 402 | return $string; 403 | } 404 | 405 | sub _readpod { 406 | my $string = Module::Install::_read($_[0]); 407 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 408 | return $string if $_[0] =~ /\.pod\z/; 409 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 410 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 411 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 412 | $string =~ s/^\n+//s; 413 | return $string; 414 | } 415 | 416 | # Done in evals to avoid confusing Perl::MinimumVersion 417 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 418 | sub _write { 419 | local *FH; 420 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 421 | binmode FH; 422 | foreach ( 1 .. $#_ ) { 423 | print FH $_[$_] or die "print($_[0]): $!"; 424 | } 425 | close FH or die "close($_[0]): $!"; 426 | } 427 | END_NEW 428 | sub _write { 429 | local *FH; 430 | open( FH, "> $_[0]" ) or die "open($_[0]): $!"; 431 | binmode FH; 432 | foreach ( 1 .. $#_ ) { 433 | print FH $_[$_] or die "print($_[0]): $!"; 434 | } 435 | close FH or die "close($_[0]): $!"; 436 | } 437 | END_OLD 438 | 439 | # _version is for processing module versions (eg, 1.03_05) not 440 | # Perl versions (eg, 5.8.1). 441 | sub _version { 442 | my $s = shift || 0; 443 | my $d =()= $s =~ /(\.)/g; 444 | if ( $d >= 2 ) { 445 | # Normalise multipart versions 446 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 447 | } 448 | $s =~ s/^(\d+)\.?//; 449 | my $l = $1 || 0; 450 | my @v = map { 451 | $_ . '0' x (3 - length $_) 452 | } $s =~ /(\d{1,3})\D?/g; 453 | $l = $l . '.' . join '', @v if @v; 454 | return $l + 0; 455 | } 456 | 457 | sub _cmp { 458 | _version($_[1]) <=> _version($_[2]); 459 | } 460 | 461 | # Cloned from Params::Util::_CLASS 462 | sub _CLASS { 463 | ( 464 | defined $_[0] 465 | and 466 | ! ref $_[0] 467 | and 468 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 469 | ) ? $_[0] : undef; 470 | } 471 | 472 | 1; 473 | 474 | # Copyright 2008 - 2012 Adam Kennedy. 475 | -------------------------------------------------------------------------------- /inc/Module/Install/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::AutoInstall; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.14'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub AutoInstall { $_[0] } 15 | 16 | sub run { 17 | my $self = shift; 18 | $self->auto_install_now(@_); 19 | } 20 | 21 | sub write { 22 | my $self = shift; 23 | $self->auto_install(@_); 24 | } 25 | 26 | sub auto_install { 27 | my $self = shift; 28 | return if $self->{done}++; 29 | 30 | # Flatten array of arrays into a single array 31 | my @core = map @$_, map @$_, grep ref, 32 | $self->build_requires, $self->requires; 33 | 34 | my @config = @_; 35 | 36 | # We'll need Module::AutoInstall 37 | $self->include('Module::AutoInstall'); 38 | require Module::AutoInstall; 39 | 40 | my @features_require = Module::AutoInstall->import( 41 | (@config ? (-config => \@config) : ()), 42 | (@core ? (-core => \@core) : ()), 43 | $self->features, 44 | ); 45 | 46 | my %seen; 47 | my @requires = map @$_, map @$_, grep ref, $self->requires; 48 | while (my ($mod, $ver) = splice(@requires, 0, 2)) { 49 | $seen{$mod}{$ver}++; 50 | } 51 | my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; 52 | while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { 53 | $seen{$mod}{$ver}++; 54 | } 55 | my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; 56 | while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { 57 | $seen{$mod}{$ver}++; 58 | } 59 | 60 | my @deduped; 61 | while (my ($mod, $ver) = splice(@features_require, 0, 2)) { 62 | push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; 63 | } 64 | 65 | $self->requires(@deduped); 66 | 67 | $self->makemaker_args( Module::AutoInstall::_make_args() ); 68 | 69 | my $class = ref($self); 70 | $self->postamble( 71 | "# --- $class section:\n" . 72 | Module::AutoInstall::postamble() 73 | ); 74 | } 75 | 76 | sub installdeps_target { 77 | my ($self, @args) = @_; 78 | 79 | $self->include('Module::AutoInstall'); 80 | require Module::AutoInstall; 81 | 82 | Module::AutoInstall::_installdeps_target(1); 83 | 84 | $self->auto_install(@args); 85 | } 86 | 87 | sub auto_install_now { 88 | my $self = shift; 89 | $self->auto_install(@_); 90 | Module::AutoInstall::do_install(); 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /inc/Module/Install/Base.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Base; 3 | 4 | use strict 'vars'; 5 | use vars qw{$VERSION}; 6 | BEGIN { 7 | $VERSION = '1.14'; 8 | } 9 | 10 | # Suspend handler for "redefined" warnings 11 | BEGIN { 12 | my $w = $SIG{__WARN__}; 13 | $SIG{__WARN__} = sub { $w }; 14 | } 15 | 16 | #line 42 17 | 18 | sub new { 19 | my $class = shift; 20 | unless ( defined &{"${class}::call"} ) { 21 | *{"${class}::call"} = sub { shift->_top->call(@_) }; 22 | } 23 | unless ( defined &{"${class}::load"} ) { 24 | *{"${class}::load"} = sub { shift->_top->load(@_) }; 25 | } 26 | bless { @_ }, $class; 27 | } 28 | 29 | #line 61 30 | 31 | sub AUTOLOAD { 32 | local $@; 33 | my $func = eval { shift->_top->autoload } or return; 34 | goto &$func; 35 | } 36 | 37 | #line 75 38 | 39 | sub _top { 40 | $_[0]->{_top}; 41 | } 42 | 43 | #line 90 44 | 45 | sub admin { 46 | $_[0]->_top->{admin} 47 | or 48 | Module::Install::Base::FakeAdmin->new; 49 | } 50 | 51 | #line 106 52 | 53 | sub is_admin { 54 | ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); 55 | } 56 | 57 | sub DESTROY {} 58 | 59 | package Module::Install::Base::FakeAdmin; 60 | 61 | use vars qw{$VERSION}; 62 | BEGIN { 63 | $VERSION = $Module::Install::Base::VERSION; 64 | } 65 | 66 | my $fake; 67 | 68 | sub new { 69 | $fake ||= bless(\@_, $_[0]); 70 | } 71 | 72 | sub AUTOLOAD {} 73 | 74 | sub DESTROY {} 75 | 76 | # Restore warning handler 77 | BEGIN { 78 | $SIG{__WARN__} = $SIG{__WARN__}->(); 79 | } 80 | 81 | 1; 82 | 83 | #line 159 84 | -------------------------------------------------------------------------------- /inc/Module/Install/Can.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Can; 3 | 4 | use strict; 5 | use Config (); 6 | use ExtUtils::MakeMaker (); 7 | use Module::Install::Base (); 8 | 9 | use vars qw{$VERSION @ISA $ISCORE}; 10 | BEGIN { 11 | $VERSION = '1.14'; 12 | @ISA = 'Module::Install::Base'; 13 | $ISCORE = 1; 14 | } 15 | 16 | # check if we can load some module 17 | ### Upgrade this to not have to load the module if possible 18 | sub can_use { 19 | my ($self, $mod, $ver) = @_; 20 | $mod =~ s{::|\\}{/}g; 21 | $mod .= '.pm' unless $mod =~ /\.pm$/i; 22 | 23 | my $pkg = $mod; 24 | $pkg =~ s{/}{::}g; 25 | $pkg =~ s{\.pm$}{}i; 26 | 27 | local $@; 28 | eval { require $mod; $pkg->VERSION($ver || 0); 1 }; 29 | } 30 | 31 | # Check if we can run some command 32 | sub can_run { 33 | my ($self, $cmd) = @_; 34 | 35 | my $_cmd = $cmd; 36 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 37 | 38 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 39 | next if $dir eq ''; 40 | require File::Spec; 41 | my $abs = File::Spec->catfile($dir, $cmd); 42 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 43 | } 44 | 45 | return; 46 | } 47 | 48 | # Can our C compiler environment build XS files 49 | sub can_xs { 50 | my $self = shift; 51 | 52 | # Ensure we have the CBuilder module 53 | $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); 54 | 55 | # Do we have the configure_requires checker? 56 | local $@; 57 | eval "require ExtUtils::CBuilder;"; 58 | if ( $@ ) { 59 | # They don't obey configure_requires, so it is 60 | # someone old and delicate. Try to avoid hurting 61 | # them by falling back to an older simpler test. 62 | return $self->can_cc(); 63 | } 64 | 65 | # Do we have a working C compiler 66 | my $builder = ExtUtils::CBuilder->new( 67 | quiet => 1, 68 | ); 69 | unless ( $builder->have_compiler ) { 70 | # No working C compiler 71 | return 0; 72 | } 73 | 74 | # Write a C file representative of what XS becomes 75 | require File::Temp; 76 | my ( $FH, $tmpfile ) = File::Temp::tempfile( 77 | "compilexs-XXXXX", 78 | SUFFIX => '.c', 79 | ); 80 | binmode $FH; 81 | print $FH <<'END_C'; 82 | #include "EXTERN.h" 83 | #include "perl.h" 84 | #include "XSUB.h" 85 | 86 | int main(int argc, char **argv) { 87 | return 0; 88 | } 89 | 90 | int boot_sanexs() { 91 | return 1; 92 | } 93 | 94 | END_C 95 | close $FH; 96 | 97 | # Can the C compiler access the same headers XS does 98 | my @libs = (); 99 | my $object = undef; 100 | eval { 101 | local $^W = 0; 102 | $object = $builder->compile( 103 | source => $tmpfile, 104 | ); 105 | @libs = $builder->link( 106 | objects => $object, 107 | module_name => 'sanexs', 108 | ); 109 | }; 110 | my $result = $@ ? 0 : 1; 111 | 112 | # Clean up all the build files 113 | foreach ( $tmpfile, $object, @libs ) { 114 | next unless defined $_; 115 | 1 while unlink; 116 | } 117 | 118 | return $result; 119 | } 120 | 121 | # Can we locate a (the) C compiler 122 | sub can_cc { 123 | my $self = shift; 124 | my @chunks = split(/ /, $Config::Config{cc}) or return; 125 | 126 | # $Config{cc} may contain args; try to find out the program part 127 | while (@chunks) { 128 | return $self->can_run("@chunks") || (pop(@chunks), next); 129 | } 130 | 131 | return; 132 | } 133 | 134 | # Fix Cygwin bug on maybe_command(); 135 | if ( $^O eq 'cygwin' ) { 136 | require ExtUtils::MM_Cygwin; 137 | require ExtUtils::MM_Win32; 138 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { 139 | *ExtUtils::MM_Cygwin::maybe_command = sub { 140 | my ($self, $file) = @_; 141 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { 142 | ExtUtils::MM_Win32->maybe_command($file); 143 | } else { 144 | ExtUtils::MM_Unix->maybe_command($file); 145 | } 146 | } 147 | } 148 | } 149 | 150 | 1; 151 | 152 | __END__ 153 | 154 | #line 236 155 | -------------------------------------------------------------------------------- /inc/Module/Install/Fetch.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Fetch; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.14'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub get_file { 15 | my ($self, %args) = @_; 16 | my ($scheme, $host, $path, $file) = 17 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 18 | 19 | if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { 20 | $args{url} = $args{ftp_url} 21 | or (warn("LWP support unavailable!\n"), return); 22 | ($scheme, $host, $path, $file) = 23 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 24 | } 25 | 26 | $|++; 27 | print "Fetching '$file' from $host... "; 28 | 29 | unless (eval { require Socket; Socket::inet_aton($host) }) { 30 | warn "'$host' resolve failed!\n"; 31 | return; 32 | } 33 | 34 | return unless $scheme eq 'ftp' or $scheme eq 'http'; 35 | 36 | require Cwd; 37 | my $dir = Cwd::getcwd(); 38 | chdir $args{local_dir} or return if exists $args{local_dir}; 39 | 40 | if (eval { require LWP::Simple; 1 }) { 41 | LWP::Simple::mirror($args{url}, $file); 42 | } 43 | elsif (eval { require Net::FTP; 1 }) { eval { 44 | # use Net::FTP to get past firewall 45 | my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); 46 | $ftp->login("anonymous", 'anonymous@example.com'); 47 | $ftp->cwd($path); 48 | $ftp->binary; 49 | $ftp->get($file) or (warn("$!\n"), return); 50 | $ftp->quit; 51 | } } 52 | elsif (my $ftp = $self->can_run('ftp')) { eval { 53 | # no Net::FTP, fallback to ftp.exe 54 | require FileHandle; 55 | my $fh = FileHandle->new; 56 | 57 | local $SIG{CHLD} = 'IGNORE'; 58 | unless ($fh->open("|$ftp -n")) { 59 | warn "Couldn't open ftp: $!\n"; 60 | chdir $dir; return; 61 | } 62 | 63 | my @dialog = split(/\n/, <<"END_FTP"); 64 | open $host 65 | user anonymous anonymous\@example.com 66 | cd $path 67 | binary 68 | get $file $file 69 | quit 70 | END_FTP 71 | foreach (@dialog) { $fh->print("$_\n") } 72 | $fh->close; 73 | } } 74 | else { 75 | warn "No working 'ftp' program available!\n"; 76 | chdir $dir; return; 77 | } 78 | 79 | unless (-f $file) { 80 | warn "Fetching failed: $@\n"; 81 | chdir $dir; return; 82 | } 83 | 84 | return if exists $args{size} and -s $file != $args{size}; 85 | system($args{run}) if exists $args{run}; 86 | unlink($file) if $args{remove}; 87 | 88 | print(((!exists $args{check_for} or -e $args{check_for}) 89 | ? "done!" : "failed! ($!)"), "\n"); 90 | chdir $dir; return !$?; 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /inc/Module/Install/Include.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Include; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.14'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub include { 15 | shift()->admin->include(@_); 16 | } 17 | 18 | sub include_deps { 19 | shift()->admin->include_deps(@_); 20 | } 21 | 22 | sub auto_include { 23 | shift()->admin->auto_include(@_); 24 | } 25 | 26 | sub auto_include_deps { 27 | shift()->admin->auto_include_deps(@_); 28 | } 29 | 30 | sub auto_include_dependent_dists { 31 | shift()->admin->auto_include_dependent_dists(@_); 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /inc/Module/Install/Makefile.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Makefile; 3 | 4 | use strict 'vars'; 5 | use ExtUtils::MakeMaker (); 6 | use Module::Install::Base (); 7 | use Fcntl qw/:flock :seek/; 8 | 9 | use vars qw{$VERSION @ISA $ISCORE}; 10 | BEGIN { 11 | $VERSION = '1.14'; 12 | @ISA = 'Module::Install::Base'; 13 | $ISCORE = 1; 14 | } 15 | 16 | sub Makefile { $_[0] } 17 | 18 | my %seen = (); 19 | 20 | sub prompt { 21 | shift; 22 | 23 | # Infinite loop protection 24 | my @c = caller(); 25 | if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { 26 | die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; 27 | } 28 | 29 | # In automated testing or non-interactive session, always use defaults 30 | if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { 31 | local $ENV{PERL_MM_USE_DEFAULT} = 1; 32 | goto &ExtUtils::MakeMaker::prompt; 33 | } else { 34 | goto &ExtUtils::MakeMaker::prompt; 35 | } 36 | } 37 | 38 | # Store a cleaned up version of the MakeMaker version, 39 | # since we need to behave differently in a variety of 40 | # ways based on the MM version. 41 | my $makemaker = eval $ExtUtils::MakeMaker::VERSION; 42 | 43 | # If we are passed a param, do a "newer than" comparison. 44 | # Otherwise, just return the MakeMaker version. 45 | sub makemaker { 46 | ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 47 | } 48 | 49 | # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified 50 | # as we only need to know here whether the attribute is an array 51 | # or a hash or something else (which may or may not be appendable). 52 | my %makemaker_argtype = ( 53 | C => 'ARRAY', 54 | CONFIG => 'ARRAY', 55 | # CONFIGURE => 'CODE', # ignore 56 | DIR => 'ARRAY', 57 | DL_FUNCS => 'HASH', 58 | DL_VARS => 'ARRAY', 59 | EXCLUDE_EXT => 'ARRAY', 60 | EXE_FILES => 'ARRAY', 61 | FUNCLIST => 'ARRAY', 62 | H => 'ARRAY', 63 | IMPORTS => 'HASH', 64 | INCLUDE_EXT => 'ARRAY', 65 | LIBS => 'ARRAY', # ignore '' 66 | MAN1PODS => 'HASH', 67 | MAN3PODS => 'HASH', 68 | META_ADD => 'HASH', 69 | META_MERGE => 'HASH', 70 | PL_FILES => 'HASH', 71 | PM => 'HASH', 72 | PMLIBDIRS => 'ARRAY', 73 | PMLIBPARENTDIRS => 'ARRAY', 74 | PREREQ_PM => 'HASH', 75 | CONFIGURE_REQUIRES => 'HASH', 76 | SKIP => 'ARRAY', 77 | TYPEMAPS => 'ARRAY', 78 | XS => 'HASH', 79 | # VERSION => ['version',''], # ignore 80 | # _KEEP_AFTER_FLUSH => '', 81 | 82 | clean => 'HASH', 83 | depend => 'HASH', 84 | dist => 'HASH', 85 | dynamic_lib=> 'HASH', 86 | linkext => 'HASH', 87 | macro => 'HASH', 88 | postamble => 'HASH', 89 | realclean => 'HASH', 90 | test => 'HASH', 91 | tool_autosplit => 'HASH', 92 | 93 | # special cases where you can use makemaker_append 94 | CCFLAGS => 'APPENDABLE', 95 | DEFINE => 'APPENDABLE', 96 | INC => 'APPENDABLE', 97 | LDDLFLAGS => 'APPENDABLE', 98 | LDFROM => 'APPENDABLE', 99 | ); 100 | 101 | sub makemaker_args { 102 | my ($self, %new_args) = @_; 103 | my $args = ( $self->{makemaker_args} ||= {} ); 104 | foreach my $key (keys %new_args) { 105 | if ($makemaker_argtype{$key}) { 106 | if ($makemaker_argtype{$key} eq 'ARRAY') { 107 | $args->{$key} = [] unless defined $args->{$key}; 108 | unless (ref $args->{$key} eq 'ARRAY') { 109 | $args->{$key} = [$args->{$key}] 110 | } 111 | push @{$args->{$key}}, 112 | ref $new_args{$key} eq 'ARRAY' 113 | ? @{$new_args{$key}} 114 | : $new_args{$key}; 115 | } 116 | elsif ($makemaker_argtype{$key} eq 'HASH') { 117 | $args->{$key} = {} unless defined $args->{$key}; 118 | foreach my $skey (keys %{ $new_args{$key} }) { 119 | $args->{$key}{$skey} = $new_args{$key}{$skey}; 120 | } 121 | } 122 | elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { 123 | $self->makemaker_append($key => $new_args{$key}); 124 | } 125 | } 126 | else { 127 | if (defined $args->{$key}) { 128 | warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; 129 | } 130 | $args->{$key} = $new_args{$key}; 131 | } 132 | } 133 | return $args; 134 | } 135 | 136 | # For mm args that take multiple space-separated args, 137 | # append an argument to the current list. 138 | sub makemaker_append { 139 | my $self = shift; 140 | my $name = shift; 141 | my $args = $self->makemaker_args; 142 | $args->{$name} = defined $args->{$name} 143 | ? join( ' ', $args->{$name}, @_ ) 144 | : join( ' ', @_ ); 145 | } 146 | 147 | sub build_subdirs { 148 | my $self = shift; 149 | my $subdirs = $self->makemaker_args->{DIR} ||= []; 150 | for my $subdir (@_) { 151 | push @$subdirs, $subdir; 152 | } 153 | } 154 | 155 | sub clean_files { 156 | my $self = shift; 157 | my $clean = $self->makemaker_args->{clean} ||= {}; 158 | %$clean = ( 159 | %$clean, 160 | FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), 161 | ); 162 | } 163 | 164 | sub realclean_files { 165 | my $self = shift; 166 | my $realclean = $self->makemaker_args->{realclean} ||= {}; 167 | %$realclean = ( 168 | %$realclean, 169 | FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), 170 | ); 171 | } 172 | 173 | sub libs { 174 | my $self = shift; 175 | my $libs = ref $_[0] ? shift : [ shift ]; 176 | $self->makemaker_args( LIBS => $libs ); 177 | } 178 | 179 | sub inc { 180 | my $self = shift; 181 | $self->makemaker_args( INC => shift ); 182 | } 183 | 184 | sub _wanted_t { 185 | } 186 | 187 | sub tests_recursive { 188 | my $self = shift; 189 | my $dir = shift || 't'; 190 | unless ( -d $dir ) { 191 | die "tests_recursive dir '$dir' does not exist"; 192 | } 193 | my %tests = map { $_ => 1 } split / /, ($self->tests || ''); 194 | require File::Find; 195 | File::Find::find( 196 | sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, 197 | $dir 198 | ); 199 | $self->tests( join ' ', sort keys %tests ); 200 | } 201 | 202 | sub write { 203 | my $self = shift; 204 | die "&Makefile->write() takes no arguments\n" if @_; 205 | 206 | # Check the current Perl version 207 | my $perl_version = $self->perl_version; 208 | if ( $perl_version ) { 209 | eval "use $perl_version; 1" 210 | or die "ERROR: perl: Version $] is installed, " 211 | . "but we need version >= $perl_version"; 212 | } 213 | 214 | # Make sure we have a new enough MakeMaker 215 | require ExtUtils::MakeMaker; 216 | 217 | if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { 218 | # This previous attempted to inherit the version of 219 | # ExtUtils::MakeMaker in use by the module author, but this 220 | # was found to be untenable as some authors build releases 221 | # using future dev versions of EU:MM that nobody else has. 222 | # Instead, #toolchain suggests we use 6.59 which is the most 223 | # stable version on CPAN at time of writing and is, to quote 224 | # ribasushi, "not terminally fucked, > and tested enough". 225 | # TODO: We will now need to maintain this over time to push 226 | # the version up as new versions are released. 227 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); 228 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); 229 | } else { 230 | # Allow legacy-compatibility with 5.005 by depending on the 231 | # most recent EU:MM that supported 5.005. 232 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); 233 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); 234 | } 235 | 236 | # Generate the MakeMaker params 237 | my $args = $self->makemaker_args; 238 | $args->{DISTNAME} = $self->name; 239 | $args->{NAME} = $self->module_name || $self->name; 240 | $args->{NAME} =~ s/-/::/g; 241 | $args->{VERSION} = $self->version or die <<'EOT'; 242 | ERROR: Can't determine distribution version. Please specify it 243 | explicitly via 'version' in Makefile.PL, or set a valid $VERSION 244 | in a module, and provide its file path via 'version_from' (or 245 | 'all_from' if you prefer) in Makefile.PL. 246 | EOT 247 | 248 | if ( $self->tests ) { 249 | my @tests = split ' ', $self->tests; 250 | my %seen; 251 | $args->{test} = { 252 | TESTS => (join ' ', grep {!$seen{$_}++} @tests), 253 | }; 254 | } elsif ( $Module::Install::ExtraTests::use_extratests ) { 255 | # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. 256 | # So, just ignore our xt tests here. 257 | } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { 258 | $args->{test} = { 259 | TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), 260 | }; 261 | } 262 | if ( $] >= 5.005 ) { 263 | $args->{ABSTRACT} = $self->abstract; 264 | $args->{AUTHOR} = join ', ', @{$self->author || []}; 265 | } 266 | if ( $self->makemaker(6.10) ) { 267 | $args->{NO_META} = 1; 268 | #$args->{NO_MYMETA} = 1; 269 | } 270 | if ( $self->makemaker(6.17) and $self->sign ) { 271 | $args->{SIGN} = 1; 272 | } 273 | unless ( $self->is_admin ) { 274 | delete $args->{SIGN}; 275 | } 276 | if ( $self->makemaker(6.31) and $self->license ) { 277 | $args->{LICENSE} = $self->license; 278 | } 279 | 280 | my $prereq = ($args->{PREREQ_PM} ||= {}); 281 | %$prereq = ( %$prereq, 282 | map { @$_ } # flatten [module => version] 283 | map { @$_ } 284 | grep $_, 285 | ($self->requires) 286 | ); 287 | 288 | # Remove any reference to perl, PREREQ_PM doesn't support it 289 | delete $args->{PREREQ_PM}->{perl}; 290 | 291 | # Merge both kinds of requires into BUILD_REQUIRES 292 | my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); 293 | %$build_prereq = ( %$build_prereq, 294 | map { @$_ } # flatten [module => version] 295 | map { @$_ } 296 | grep $_, 297 | ($self->configure_requires, $self->build_requires) 298 | ); 299 | 300 | # Remove any reference to perl, BUILD_REQUIRES doesn't support it 301 | delete $args->{BUILD_REQUIRES}->{perl}; 302 | 303 | # Delete bundled dists from prereq_pm, add it to Makefile DIR 304 | my $subdirs = ($args->{DIR} || []); 305 | if ($self->bundles) { 306 | my %processed; 307 | foreach my $bundle (@{ $self->bundles }) { 308 | my ($mod_name, $dist_dir) = @$bundle; 309 | delete $prereq->{$mod_name}; 310 | $dist_dir = File::Basename::basename($dist_dir); # dir for building this module 311 | if (not exists $processed{$dist_dir}) { 312 | if (-d $dist_dir) { 313 | # List as sub-directory to be processed by make 314 | push @$subdirs, $dist_dir; 315 | } 316 | # Else do nothing: the module is already present on the system 317 | $processed{$dist_dir} = undef; 318 | } 319 | } 320 | } 321 | 322 | unless ( $self->makemaker('6.55_03') ) { 323 | %$prereq = (%$prereq,%$build_prereq); 324 | delete $args->{BUILD_REQUIRES}; 325 | } 326 | 327 | if ( my $perl_version = $self->perl_version ) { 328 | eval "use $perl_version; 1" 329 | or die "ERROR: perl: Version $] is installed, " 330 | . "but we need version >= $perl_version"; 331 | 332 | if ( $self->makemaker(6.48) ) { 333 | $args->{MIN_PERL_VERSION} = $perl_version; 334 | } 335 | } 336 | 337 | if ($self->installdirs) { 338 | warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; 339 | $args->{INSTALLDIRS} = $self->installdirs; 340 | } 341 | 342 | my %args = map { 343 | ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) 344 | } keys %$args; 345 | 346 | my $user_preop = delete $args{dist}->{PREOP}; 347 | if ( my $preop = $self->admin->preop($user_preop) ) { 348 | foreach my $key ( keys %$preop ) { 349 | $args{dist}->{$key} = $preop->{$key}; 350 | } 351 | } 352 | 353 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); 354 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); 355 | } 356 | 357 | sub fix_up_makefile { 358 | my $self = shift; 359 | my $makefile_name = shift; 360 | my $top_class = ref($self->_top) || ''; 361 | my $top_version = $self->_top->VERSION || ''; 362 | 363 | my $preamble = $self->preamble 364 | ? "# Preamble by $top_class $top_version\n" 365 | . $self->preamble 366 | : ''; 367 | my $postamble = "# Postamble by $top_class $top_version\n" 368 | . ($self->postamble || ''); 369 | 370 | local *MAKEFILE; 371 | open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 372 | eval { flock MAKEFILE, LOCK_EX }; 373 | my $makefile = do { local $/; }; 374 | 375 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; 376 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; 377 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; 378 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; 379 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; 380 | 381 | # Module::Install will never be used to build the Core Perl 382 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks 383 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist 384 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; 385 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; 386 | 387 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. 388 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; 389 | 390 | # XXX - This is currently unused; not sure if it breaks other MM-users 391 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; 392 | 393 | seek MAKEFILE, 0, SEEK_SET; 394 | truncate MAKEFILE, 0; 395 | print MAKEFILE "$preamble$makefile$postamble" or die $!; 396 | close MAKEFILE or die $!; 397 | 398 | 1; 399 | } 400 | 401 | sub preamble { 402 | my ($self, $text) = @_; 403 | $self->{preamble} = $text . $self->{preamble} if defined $text; 404 | $self->{preamble}; 405 | } 406 | 407 | sub postamble { 408 | my ($self, $text) = @_; 409 | $self->{postamble} ||= $self->admin->postamble; 410 | $self->{postamble} .= $text if defined $text; 411 | $self->{postamble} 412 | } 413 | 414 | 1; 415 | 416 | __END__ 417 | 418 | #line 544 419 | -------------------------------------------------------------------------------- /inc/Module/Install/Scripts.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Scripts; 3 | 4 | use strict 'vars'; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.14'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub install_script { 15 | my $self = shift; 16 | my $args = $self->makemaker_args; 17 | my $exe = $args->{EXE_FILES} ||= []; 18 | foreach ( @_ ) { 19 | if ( -f $_ ) { 20 | push @$exe, $_; 21 | } elsif ( -d 'script' and -f "script/$_" ) { 22 | push @$exe, "script/$_"; 23 | } else { 24 | die("Cannot find script '$_'"); 25 | } 26 | } 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /inc/Module/Install/TestBase.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::TestBase; 3 | use strict; 4 | use warnings; 5 | 6 | use Module::Install::Base; 7 | 8 | use vars qw($VERSION @ISA); 9 | BEGIN { 10 | $VERSION = '0.86'; 11 | @ISA = 'Module::Install::Base'; 12 | } 13 | 14 | sub use_test_base { 15 | my $self = shift; 16 | $self->include('Test::Base'); 17 | $self->include('Test::Base::Filter'); 18 | $self->include('Spiffy'); 19 | $self->include('Test::More'); 20 | $self->include('Test::Builder'); 21 | $self->include('Test::Builder::Module'); 22 | $self->requires('Filter::Util::Call'); 23 | } 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /inc/Module/Install/Win32.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Win32; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.14'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | # determine if the user needs nmake, and download it if needed 15 | sub check_nmake { 16 | my $self = shift; 17 | $self->load('can_run'); 18 | $self->load('get_file'); 19 | 20 | require Config; 21 | return unless ( 22 | $^O eq 'MSWin32' and 23 | $Config::Config{make} and 24 | $Config::Config{make} =~ /^nmake\b/i and 25 | ! $self->can_run('nmake') 26 | ); 27 | 28 | print "The required 'nmake' executable not found, fetching it...\n"; 29 | 30 | require File::Basename; 31 | my $rv = $self->get_file( 32 | url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', 33 | ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', 34 | local_dir => File::Basename::dirname($^X), 35 | size => 51928, 36 | run => 'Nmake15.exe /o > nul', 37 | check_for => 'Nmake.exe', 38 | remove => 1, 39 | ); 40 | 41 | die <<'END_MESSAGE' unless $rv; 42 | 43 | ------------------------------------------------------------------------------- 44 | 45 | Since you are using Microsoft Windows, you will need the 'nmake' utility 46 | before installation. It's available at: 47 | 48 | http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe 49 | or 50 | ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe 51 | 52 | Please download the file manually, save it to a directory in %PATH% (e.g. 53 | C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to 54 | that directory, and run "Nmake15.exe" from there; that will create the 55 | 'nmake.exe' file needed by this module. 56 | 57 | You may then resume the installation process described in README. 58 | 59 | ------------------------------------------------------------------------------- 60 | END_MESSAGE 61 | 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /inc/Module/Install/WriteAll.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::WriteAll; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.14'; 10 | @ISA = qw{Module::Install::Base}; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub WriteAll { 15 | my $self = shift; 16 | my %args = ( 17 | meta => 1, 18 | sign => 0, 19 | inline => 0, 20 | check_nmake => 1, 21 | @_, 22 | ); 23 | 24 | $self->sign(1) if $args{sign}; 25 | $self->admin->WriteAll(%args) if $self->is_admin; 26 | 27 | $self->check_nmake if $args{check_nmake}; 28 | unless ( $self->makemaker_args->{PL_FILES} ) { 29 | # XXX: This still may be a bit over-defensive... 30 | unless ($self->makemaker(6.25)) { 31 | $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; 32 | } 33 | } 34 | 35 | # Until ExtUtils::MakeMaker support MYMETA.yml, make sure 36 | # we clean it up properly ourself. 37 | $self->realclean_files('MYMETA.yml'); 38 | 39 | if ( $args{inline} ) { 40 | $self->Inline->write; 41 | } else { 42 | $self->Makefile->write; 43 | } 44 | 45 | # The Makefile write process adds a couple of dependencies, 46 | # so write the META.yml files after the Makefile. 47 | if ( $args{meta} ) { 48 | $self->Meta->write; 49 | } 50 | 51 | # Experimental support for MYMETA 52 | if ( $ENV{X_MYMETA} ) { 53 | if ( $ENV{X_MYMETA} eq 'JSON' ) { 54 | $self->Meta->write_mymeta_json; 55 | } else { 56 | $self->Meta->write_mymeta_yaml; 57 | } 58 | } 59 | 60 | return 1; 61 | } 62 | 63 | 1; 64 | -------------------------------------------------------------------------------- /inc/Spiffy.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | use strict; use warnings; 3 | package Spiffy; 4 | our $VERSION = '0.46'; 5 | 6 | use Carp; 7 | require Exporter; 8 | our @EXPORT = (); 9 | our @EXPORT_BASE = qw(field const stub super); 10 | our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); 11 | our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); 12 | 13 | my $stack_frame = 0; 14 | my $dump = 'yaml'; 15 | my $bases_map = {}; 16 | 17 | sub WWW; sub XXX; sub YYY; sub ZZZ; 18 | 19 | # This line is here to convince "autouse" into believing we are autousable. 20 | sub can { 21 | ($_[1] eq 'import' and caller()->isa('autouse')) 22 | ? \&Exporter::import # pacify autouse's equality test 23 | : $_[0]->SUPER::can($_[1]) # normal case 24 | } 25 | 26 | # TODO 27 | # 28 | # Exported functions like field and super should be hidden so as not to 29 | # be confused with methods that can be inherited. 30 | # 31 | 32 | sub new { 33 | my $class = shift; 34 | $class = ref($class) || $class; 35 | my $self = bless {}, $class; 36 | while (@_) { 37 | my $method = shift; 38 | $self->$method(shift); 39 | } 40 | return $self; 41 | } 42 | 43 | my $filtered_files = {}; 44 | my $filter_dump = 0; 45 | my $filter_save = 0; 46 | our $filter_result = ''; 47 | sub import { 48 | no strict 'refs'; 49 | no warnings; 50 | my $self_package = shift; 51 | 52 | # XXX Using parse_arguments here might cause confusion, because the 53 | # subclass's boolean_arguments and paired_arguments can conflict, causing 54 | # difficult debugging. Consider using something truly local. 55 | my ($args, @export_list) = do { 56 | local *boolean_arguments = sub { 57 | qw( 58 | -base -Base -mixin -selfless 59 | -XXX -dumper -yaml 60 | -filter_dump -filter_save 61 | ) 62 | }; 63 | local *paired_arguments = sub { qw(-package) }; 64 | $self_package->parse_arguments(@_); 65 | }; 66 | return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list) 67 | if $args->{-mixin}; 68 | 69 | $filter_dump = 1 if $args->{-filter_dump}; 70 | $filter_save = 1 if $args->{-filter_save}; 71 | $dump = 'yaml' if $args->{-yaml}; 72 | $dump = 'dumper' if $args->{-dumper}; 73 | 74 | local @EXPORT_BASE = @EXPORT_BASE; 75 | 76 | if ($args->{-XXX}) { 77 | push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}} 78 | unless grep /^XXX$/, @EXPORT_BASE; 79 | } 80 | 81 | spiffy_filter() 82 | if ($args->{-selfless} or $args->{-Base}) and 83 | not $filtered_files->{(caller($stack_frame))[1]}++; 84 | 85 | my $caller_package = $args->{-package} || caller($stack_frame); 86 | push @{"$caller_package\::ISA"}, $self_package 87 | if $args->{-Base} or $args->{-base}; 88 | 89 | for my $class (@{all_my_bases($self_package)}) { 90 | next unless $class->isa('Spiffy'); 91 | my @export = grep { 92 | not defined &{"$caller_package\::$_"}; 93 | } ( @{"$class\::EXPORT"}, 94 | ($args->{-Base} or $args->{-base}) 95 | ? @{"$class\::EXPORT_BASE"} : (), 96 | ); 97 | my @export_ok = grep { 98 | not defined &{"$caller_package\::$_"}; 99 | } @{"$class\::EXPORT_OK"}; 100 | 101 | # Avoid calling the expensive Exporter::export 102 | # if there is nothing to do (optimization) 103 | my %exportable = map { ($_, 1) } @export, @export_ok; 104 | next unless keys %exportable; 105 | 106 | my @export_save = @{"$class\::EXPORT"}; 107 | my @export_ok_save = @{"$class\::EXPORT_OK"}; 108 | @{"$class\::EXPORT"} = @export; 109 | @{"$class\::EXPORT_OK"} = @export_ok; 110 | my @list = grep { 111 | (my $v = $_) =~ s/^[\!\:]//; 112 | $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v}; 113 | } @export_list; 114 | Exporter::export($class, $caller_package, @list); 115 | @{"$class\::EXPORT"} = @export_save; 116 | @{"$class\::EXPORT_OK"} = @export_ok_save; 117 | } 118 | } 119 | 120 | sub spiffy_filter { 121 | require Filter::Util::Call; 122 | my $done = 0; 123 | Filter::Util::Call::filter_add( 124 | sub { 125 | return 0 if $done; 126 | my ($data, $end) = ('', ''); 127 | while (my $status = Filter::Util::Call::filter_read()) { 128 | return $status if $status < 0; 129 | if (/^__(?:END|DATA)__\r?$/) { 130 | $end = $_; 131 | last; 132 | } 133 | $data .= $_; 134 | $_ = ''; 135 | } 136 | $_ = $data; 137 | my @my_subs; 138 | s[^(sub\s+\w+\s+\{)(.*\n)] 139 | [${1}my \$self = shift;$2]gm; 140 | s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)] 141 | [${1}${2}]gm; 142 | s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n] 143 | [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem; 144 | my $preclare = ''; 145 | if (@my_subs) { 146 | $preclare = join ',', map "\$$_", @my_subs; 147 | $preclare = "my($preclare);"; 148 | } 149 | $_ = "use strict;use warnings;$preclare${_};1;\n$end"; 150 | if ($filter_dump) { print; exit } 151 | if ($filter_save) { $filter_result = $_; $_ = $filter_result; } 152 | $done = 1; 153 | } 154 | ); 155 | } 156 | 157 | sub base { 158 | push @_, -base; 159 | goto &import; 160 | } 161 | 162 | sub all_my_bases { 163 | my $class = shift; 164 | 165 | return $bases_map->{$class} 166 | if defined $bases_map->{$class}; 167 | 168 | my @bases = ($class); 169 | no strict 'refs'; 170 | for my $base_class (@{"${class}::ISA"}) { 171 | push @bases, @{all_my_bases($base_class)}; 172 | } 173 | my $used = {}; 174 | $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; 175 | } 176 | 177 | my %code = ( 178 | sub_start => 179 | "sub {\n", 180 | set_default => 181 | " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", 182 | init => 183 | " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . 184 | " unless \$#_ > 0 or defined \$_[0]->{%s};\n", 185 | weak_init => 186 | " return do {\n" . 187 | " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" . 188 | " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . 189 | " \$_[0]->{%s};\n" . 190 | " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", 191 | return_if_get => 192 | " return \$_[0]->{%s} unless \$#_ > 0;\n", 193 | set => 194 | " \$_[0]->{%s} = \$_[1];\n", 195 | weaken => 196 | " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", 197 | sub_end => 198 | " return \$_[0]->{%s};\n}\n", 199 | ); 200 | 201 | sub field { 202 | my $package = caller; 203 | my ($args, @values) = do { 204 | no warnings; 205 | local *boolean_arguments = sub { (qw(-weak)) }; 206 | local *paired_arguments = sub { (qw(-package -init)) }; 207 | Spiffy->parse_arguments(@_); 208 | }; 209 | my ($field, $default) = @values; 210 | $package = $args->{-package} if defined $args->{-package}; 211 | die "Cannot have a default for a weakened field ($field)" 212 | if defined $default && $args->{-weak}; 213 | return if defined &{"${package}::$field"}; 214 | require Scalar::Util if $args->{-weak}; 215 | my $default_string = 216 | ( ref($default) eq 'ARRAY' and not @$default ) 217 | ? '[]' 218 | : (ref($default) eq 'HASH' and not keys %$default ) 219 | ? '{}' 220 | : default_as_code($default); 221 | 222 | my $code = $code{sub_start}; 223 | if ($args->{-init}) { 224 | my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; 225 | my @count = ($fragment =~ /(%s)/g); 226 | $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2); 227 | } 228 | $code .= sprintf $code{set_default}, $field, $default_string, $field 229 | if defined $default; 230 | $code .= sprintf $code{return_if_get}, $field; 231 | $code .= sprintf $code{set}, $field; 232 | $code .= sprintf $code{weaken}, $field, $field 233 | if $args->{-weak}; 234 | $code .= sprintf $code{sub_end}, $field; 235 | 236 | my $sub = eval $code; 237 | die $@ if $@; 238 | no strict 'refs'; 239 | *{"${package}::$field"} = $sub; 240 | return $code if defined wantarray; 241 | } 242 | 243 | sub default_as_code { 244 | require Data::Dumper; 245 | local $Data::Dumper::Sortkeys = 1; 246 | my $code = Data::Dumper::Dumper(shift); 247 | $code =~ s/^\$VAR1 = //; 248 | $code =~ s/;$//; 249 | return $code; 250 | } 251 | 252 | sub const { 253 | my $package = caller; 254 | my ($args, @values) = do { 255 | no warnings; 256 | local *paired_arguments = sub { (qw(-package)) }; 257 | Spiffy->parse_arguments(@_); 258 | }; 259 | my ($field, $default) = @values; 260 | $package = $args->{-package} if defined $args->{-package}; 261 | no strict 'refs'; 262 | return if defined &{"${package}::$field"}; 263 | *{"${package}::$field"} = sub { $default } 264 | } 265 | 266 | sub stub { 267 | my $package = caller; 268 | my ($args, @values) = do { 269 | no warnings; 270 | local *paired_arguments = sub { (qw(-package)) }; 271 | Spiffy->parse_arguments(@_); 272 | }; 273 | my ($field, $default) = @values; 274 | $package = $args->{-package} if defined $args->{-package}; 275 | no strict 'refs'; 276 | return if defined &{"${package}::$field"}; 277 | *{"${package}::$field"} = 278 | sub { 279 | require Carp; 280 | Carp::confess 281 | "Method $field in package $package must be subclassed"; 282 | } 283 | } 284 | 285 | sub parse_arguments { 286 | my $class = shift; 287 | my ($args, @values) = ({}, ()); 288 | my %booleans = map { ($_, 1) } $class->boolean_arguments; 289 | my %pairs = map { ($_, 1) } $class->paired_arguments; 290 | while (@_) { 291 | my $elem = shift; 292 | if (defined $elem and defined $booleans{$elem}) { 293 | $args->{$elem} = (@_ and $_[0] =~ /^[01]$/) 294 | ? shift 295 | : 1; 296 | } 297 | elsif (defined $elem and defined $pairs{$elem} and @_) { 298 | $args->{$elem} = shift; 299 | } 300 | else { 301 | push @values, $elem; 302 | } 303 | } 304 | return wantarray ? ($args, @values) : $args; 305 | } 306 | 307 | sub boolean_arguments { () } 308 | sub paired_arguments { () } 309 | 310 | # get a unique id for any node 311 | sub id { 312 | if (not ref $_[0]) { 313 | return 'undef' if not defined $_[0]; 314 | \$_[0] =~ /\((\w+)\)$/o or die; 315 | return "$1-S"; 316 | } 317 | require overload; 318 | overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die; 319 | return $1; 320 | } 321 | 322 | #=============================================================================== 323 | # It's super, man. 324 | #=============================================================================== 325 | package DB; 326 | { 327 | no warnings 'redefine'; 328 | sub super_args { 329 | my @dummy = caller(@_ ? $_[0] : 2); 330 | return @DB::args; 331 | } 332 | } 333 | 334 | package Spiffy; 335 | sub super { 336 | my $method; 337 | my $frame = 1; 338 | while ($method = (caller($frame++))[3]) { 339 | $method =~ s/.*::// and last; 340 | } 341 | my @args = DB::super_args($frame); 342 | @_ = @_ ? ($args[0], @_) : @args; 343 | my $class = ref $_[0] ? ref $_[0] : $_[0]; 344 | my $caller_class = caller; 345 | my $seen = 0; 346 | my @super_classes = reverse grep { 347 | ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1; 348 | } reverse @{all_my_bases($class)}; 349 | for my $super_class (@super_classes) { 350 | no strict 'refs'; 351 | next if $super_class eq $class; 352 | if (defined &{"${super_class}::$method"}) { 353 | ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"} 354 | if $method eq 'AUTOLOAD'; 355 | return &{"${super_class}::$method"}; 356 | } 357 | } 358 | return; 359 | } 360 | 361 | #=============================================================================== 362 | # This code deserves a spanking, because it is being very naughty. 363 | # It is exchanging base.pm's import() for its own, so that people 364 | # can use base.pm with Spiffy modules, without being the wiser. 365 | #=============================================================================== 366 | my $real_base_import; 367 | my $real_mixin_import; 368 | 369 | BEGIN { 370 | require base unless defined $INC{'base.pm'}; 371 | $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm'; 372 | $real_base_import = \&base::import; 373 | $real_mixin_import = \&mixin::import; 374 | no warnings; 375 | *base::import = \&spiffy_base_import; 376 | *mixin::import = \&spiffy_mixin_import; 377 | } 378 | 379 | # my $i = 0; 380 | # while (my $caller = caller($i++)) { 381 | # next unless $caller eq 'base' or $caller eq 'mixin'; 382 | # croak <isa('Spiffy'); 396 | } @base_classes; 397 | my $inheritor = caller(0); 398 | for my $base_class (@base_classes) { 399 | next if $inheritor->isa($base_class); 400 | croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", 401 | "See the documentation of Spiffy.pm for details\n " 402 | unless $base_class->isa('Spiffy'); 403 | $stack_frame = 1; # tell import to use different caller 404 | import($base_class, '-base'); 405 | $stack_frame = 0; 406 | } 407 | } 408 | 409 | sub mixin { 410 | my $self = shift; 411 | my $target_class = ref($self); 412 | spiffy_mixin_import($target_class, @_) 413 | } 414 | 415 | sub spiffy_mixin_import { 416 | my $target_class = shift; 417 | $target_class = caller(0) 418 | if $target_class eq 'mixin'; 419 | my $mixin_class = shift 420 | or die "Nothing to mixin"; 421 | eval "require $mixin_class"; 422 | my @roles = @_; 423 | my $pseudo_class = join '-', $target_class, $mixin_class, @roles; 424 | my %methods = spiffy_mixin_methods($mixin_class, @roles); 425 | no strict 'refs'; 426 | no warnings; 427 | @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; 428 | @{"$target_class\::ISA"} = ($pseudo_class); 429 | for (keys %methods) { 430 | *{"$pseudo_class\::$_"} = $methods{$_}; 431 | } 432 | } 433 | 434 | sub spiffy_mixin_methods { 435 | my $mixin_class = shift; 436 | no strict 'refs'; 437 | my %methods = spiffy_all_methods($mixin_class); 438 | map { 439 | $methods{$_} 440 | ? ($_, \ &{"$methods{$_}\::$_"}) 441 | : ($_, \ &{"$mixin_class\::$_"}) 442 | } @_ 443 | ? (get_roles($mixin_class, @_)) 444 | : (keys %methods); 445 | } 446 | 447 | sub get_roles { 448 | my $mixin_class = shift; 449 | my @roles = @_; 450 | while (grep /^!*:/, @roles) { 451 | @roles = map { 452 | s/!!//g; 453 | /^!:(.*)/ ? do { 454 | my $m = "_role_$1"; 455 | map("!$_", $mixin_class->$m); 456 | } : 457 | /^:(.*)/ ? do { 458 | my $m = "_role_$1"; 459 | ($mixin_class->$m); 460 | } : 461 | ($_) 462 | } @roles; 463 | } 464 | if (@roles and $roles[0] =~ /^!/) { 465 | my %methods = spiffy_all_methods($mixin_class); 466 | unshift @roles, keys(%methods); 467 | } 468 | my %roles; 469 | for (@roles) { 470 | s/!!//g; 471 | delete $roles{$1}, next 472 | if /^!(.*)/; 473 | $roles{$_} = 1; 474 | } 475 | keys %roles; 476 | } 477 | 478 | sub spiffy_all_methods { 479 | no strict 'refs'; 480 | my $class = shift; 481 | return if $class eq 'Spiffy'; 482 | my %methods = map { 483 | ($_, $class) 484 | } grep { 485 | defined &{"$class\::$_"} and not /^_/ 486 | } keys %{"$class\::"}; 487 | my %super_methods; 488 | %super_methods = spiffy_all_methods(${"$class\::ISA"}[0]) 489 | if @{"$class\::ISA"}; 490 | %{{%super_methods, %methods}}; 491 | } 492 | 493 | 494 | # END of naughty code. 495 | #=============================================================================== 496 | # Debugging support 497 | #=============================================================================== 498 | sub spiffy_dump { 499 | no warnings; 500 | if ($dump eq 'dumper') { 501 | require Data::Dumper; 502 | $Data::Dumper::Sortkeys = 1; 503 | $Data::Dumper::Indent = 1; 504 | return Data::Dumper::Dumper(@_); 505 | } 506 | require YAML; 507 | $YAML::UseVersion = 0; 508 | return YAML::Dump(@_) . "...\n"; 509 | } 510 | 511 | sub at_line_number { 512 | my ($file_path, $line_number) = (caller(1))[1,2]; 513 | " at $file_path line $line_number\n"; 514 | } 515 | 516 | sub WWW { 517 | warn spiffy_dump(@_) . at_line_number; 518 | return wantarray ? @_ : $_[0]; 519 | } 520 | 521 | sub XXX { 522 | die spiffy_dump(@_) . at_line_number; 523 | } 524 | 525 | sub YYY { 526 | print spiffy_dump(@_) . at_line_number; 527 | return wantarray ? @_ : $_[0]; 528 | } 529 | 530 | sub ZZZ { 531 | require Carp; 532 | Carp::confess spiffy_dump(@_); 533 | } 534 | 535 | 1; 536 | -------------------------------------------------------------------------------- /inc/Test/Base/Filter.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | #=============================================================================== 3 | # This is the default class for handling Test::Base data filtering. 4 | #=============================================================================== 5 | package Test::Base::Filter; 6 | use Spiffy -Base; 7 | use Spiffy ':XXX'; 8 | 9 | field 'current_block'; 10 | 11 | our $arguments; 12 | sub current_arguments { 13 | return undef unless defined $arguments; 14 | my $args = $arguments; 15 | $args =~ s/(\\s)/ /g; 16 | $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; 17 | return $args; 18 | } 19 | 20 | sub assert_scalar { 21 | return if @_ == 1; 22 | require Carp; 23 | my $filter = (caller(1))[3]; 24 | $filter =~ s/.*:://; 25 | Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; 26 | } 27 | 28 | sub _apply_deepest { 29 | my $method = shift; 30 | return () unless @_; 31 | if (ref $_[0] eq 'ARRAY') { 32 | for my $aref (@_) { 33 | @$aref = $self->_apply_deepest($method, @$aref); 34 | } 35 | return @_; 36 | } 37 | $self->$method(@_); 38 | } 39 | 40 | sub _split_array { 41 | map { 42 | [$self->split($_)]; 43 | } @_; 44 | } 45 | 46 | sub _peel_deepest { 47 | return () unless @_; 48 | if (ref $_[0] eq 'ARRAY') { 49 | if (ref $_[0]->[0] eq 'ARRAY') { 50 | for my $aref (@_) { 51 | @$aref = $self->_peel_deepest(@$aref); 52 | } 53 | return @_; 54 | } 55 | return map { $_->[0] } @_; 56 | } 57 | return @_; 58 | } 59 | 60 | #=============================================================================== 61 | # these filters work on the leaves of nested arrays 62 | #=============================================================================== 63 | sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } 64 | sub Reverse { $self->_apply_deepest(reverse => @_) } 65 | sub Split { $self->_apply_deepest(_split_array => @_) } 66 | sub Sort { $self->_apply_deepest(sort => @_) } 67 | 68 | 69 | sub append { 70 | my $suffix = $self->current_arguments; 71 | map { $_ . $suffix } @_; 72 | } 73 | 74 | sub array { 75 | return [@_]; 76 | } 77 | 78 | sub base64_decode { 79 | $self->assert_scalar(@_); 80 | require MIME::Base64; 81 | MIME::Base64::decode_base64(shift); 82 | } 83 | 84 | sub base64_encode { 85 | $self->assert_scalar(@_); 86 | require MIME::Base64; 87 | MIME::Base64::encode_base64(shift); 88 | } 89 | 90 | sub chomp { 91 | map { CORE::chomp; $_ } @_; 92 | } 93 | 94 | sub chop { 95 | map { CORE::chop; $_ } @_; 96 | } 97 | 98 | sub dumper { 99 | no warnings 'once'; 100 | require Data::Dumper; 101 | local $Data::Dumper::Sortkeys = 1; 102 | local $Data::Dumper::Indent = 1; 103 | local $Data::Dumper::Terse = 1; 104 | Data::Dumper::Dumper(@_); 105 | } 106 | 107 | sub escape { 108 | $self->assert_scalar(@_); 109 | my $text = shift; 110 | $text =~ s/(\\.)/eval "qq{$1}"/ge; 111 | return $text; 112 | } 113 | 114 | sub eval { 115 | $self->assert_scalar(@_); 116 | my @return = CORE::eval(shift); 117 | return $@ if $@; 118 | return @return; 119 | } 120 | 121 | sub eval_all { 122 | $self->assert_scalar(@_); 123 | my $out = ''; 124 | my $err = ''; 125 | Test::Base::tie_output(*STDOUT, $out); 126 | Test::Base::tie_output(*STDERR, $err); 127 | my $return = CORE::eval(shift); 128 | no warnings; 129 | untie *STDOUT; 130 | untie *STDERR; 131 | return $return, $@, $out, $err; 132 | } 133 | 134 | sub eval_stderr { 135 | $self->assert_scalar(@_); 136 | my $output = ''; 137 | Test::Base::tie_output(*STDERR, $output); 138 | CORE::eval(shift); 139 | no warnings; 140 | untie *STDERR; 141 | return $output; 142 | } 143 | 144 | sub eval_stdout { 145 | $self->assert_scalar(@_); 146 | my $output = ''; 147 | Test::Base::tie_output(*STDOUT, $output); 148 | CORE::eval(shift); 149 | no warnings; 150 | untie *STDOUT; 151 | return $output; 152 | } 153 | 154 | sub exec_perl_stdout { 155 | my $tmpfile = "/tmp/test-blocks-$$"; 156 | $self->_write_to($tmpfile, @_); 157 | open my $execution, "$^X $tmpfile 2>&1 |" 158 | or die "Couldn't open subprocess: $!\n"; 159 | local $/; 160 | my $output = <$execution>; 161 | close $execution; 162 | unlink($tmpfile) 163 | or die "Couldn't unlink $tmpfile: $!\n"; 164 | return $output; 165 | } 166 | 167 | sub flatten { 168 | $self->assert_scalar(@_); 169 | my $ref = shift; 170 | if (ref($ref) eq 'HASH') { 171 | return map { 172 | ($_, $ref->{$_}); 173 | } sort keys %$ref; 174 | } 175 | if (ref($ref) eq 'ARRAY') { 176 | return @$ref; 177 | } 178 | die "Can only flatten a hash or array ref"; 179 | } 180 | 181 | sub get_url { 182 | $self->assert_scalar(@_); 183 | my $url = shift; 184 | CORE::chomp($url); 185 | require LWP::Simple; 186 | LWP::Simple::get($url); 187 | } 188 | 189 | sub hash { 190 | return +{ @_ }; 191 | } 192 | 193 | sub head { 194 | my $size = $self->current_arguments || 1; 195 | return splice(@_, 0, $size); 196 | } 197 | 198 | sub join { 199 | my $string = $self->current_arguments; 200 | $string = '' unless defined $string; 201 | CORE::join $string, @_; 202 | } 203 | 204 | sub lines { 205 | $self->assert_scalar(@_); 206 | my $text = shift; 207 | return () unless length $text; 208 | my @lines = ($text =~ /^(.*\n?)/gm); 209 | return @lines; 210 | } 211 | 212 | sub norm { 213 | $self->assert_scalar(@_); 214 | my $text = shift; 215 | $text = '' unless defined $text; 216 | $text =~ s/\015\012/\n/g; 217 | $text =~ s/\r/\n/g; 218 | return $text; 219 | } 220 | 221 | sub prepend { 222 | my $prefix = $self->current_arguments; 223 | map { $prefix . $_ } @_; 224 | } 225 | 226 | sub read_file { 227 | $self->assert_scalar(@_); 228 | my $file = shift; 229 | CORE::chomp $file; 230 | open my $fh, $file 231 | or die "Can't open '$file' for input:\n$!"; 232 | CORE::join '', <$fh>; 233 | } 234 | 235 | sub regexp { 236 | $self->assert_scalar(@_); 237 | my $text = shift; 238 | my $flags = $self->current_arguments; 239 | if ($text =~ /\n.*?\n/s) { 240 | $flags = 'xism' 241 | unless defined $flags; 242 | } 243 | else { 244 | CORE::chomp($text); 245 | } 246 | $flags ||= ''; 247 | my $regexp = eval "qr{$text}$flags"; 248 | die $@ if $@; 249 | return $regexp; 250 | } 251 | 252 | sub reverse { 253 | CORE::reverse(@_); 254 | } 255 | 256 | sub slice { 257 | die "Invalid args for slice" 258 | unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; 259 | my ($x, $y) = ($1, $2); 260 | $y = $x if not defined $y; 261 | die "Invalid args for slice" 262 | if $x > $y; 263 | return splice(@_, $x, 1 + $y - $x); 264 | } 265 | 266 | sub sort { 267 | CORE::sort(@_); 268 | } 269 | 270 | sub split { 271 | $self->assert_scalar(@_); 272 | my $separator = $self->current_arguments; 273 | if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { 274 | my $regexp = $1; 275 | $separator = qr{$regexp}; 276 | } 277 | $separator = qr/\s+/ unless $separator; 278 | CORE::split $separator, shift; 279 | } 280 | 281 | sub strict { 282 | $self->assert_scalar(@_); 283 | <<'...' . shift; 284 | use strict; 285 | use warnings; 286 | ... 287 | } 288 | 289 | sub tail { 290 | my $size = $self->current_arguments || 1; 291 | return splice(@_, @_ - $size, $size); 292 | } 293 | 294 | sub trim { 295 | map { 296 | s/\A([ \t]*\n)+//; 297 | s/(?<=\n)\s*\z//g; 298 | $_; 299 | } @_; 300 | } 301 | 302 | sub unchomp { 303 | map { $_ . "\n" } @_; 304 | } 305 | 306 | sub write_file { 307 | my $file = $self->current_arguments 308 | or die "No file specified for write_file filter"; 309 | if ($file =~ /(.*)[\\\/]/) { 310 | my $dir = $1; 311 | if (not -e $dir) { 312 | require File::Path; 313 | File::Path::mkpath($dir) 314 | or die "Can't create $dir"; 315 | } 316 | } 317 | open my $fh, ">$file" 318 | or die "Can't open '$file' for output\n:$!"; 319 | print $fh @_; 320 | close $fh; 321 | return $file; 322 | } 323 | 324 | sub yaml { 325 | $self->assert_scalar(@_); 326 | require YAML; 327 | return YAML::Load(shift); 328 | } 329 | 330 | sub _write_to { 331 | my $filename = shift; 332 | open my $script, ">$filename" 333 | or die "Couldn't open $filename: $!\n"; 334 | print $script @_; 335 | close $script 336 | or die "Couldn't close $filename: $!\n"; 337 | } 338 | 339 | 1; 340 | -------------------------------------------------------------------------------- /inc/Test/Builder/Module.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Test::Builder::Module; 3 | 4 | use strict; 5 | 6 | use Test::Builder 1.00; 7 | 8 | require Exporter; 9 | our @ISA = qw(Exporter); 10 | 11 | our $VERSION = '1.001014'; 12 | $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 13 | 14 | 15 | #line 74 16 | 17 | sub import { 18 | my($class) = shift; 19 | 20 | # Don't run all this when loading ourself. 21 | return 1 if $class eq 'Test::Builder::Module'; 22 | 23 | my $test = $class->builder; 24 | 25 | my $caller = caller; 26 | 27 | $test->exported_to($caller); 28 | 29 | $class->import_extra( \@_ ); 30 | my(@imports) = $class->_strip_imports( \@_ ); 31 | 32 | $test->plan(@_); 33 | 34 | $class->export_to_level( 1, $class, @imports ); 35 | } 36 | 37 | sub _strip_imports { 38 | my $class = shift; 39 | my $list = shift; 40 | 41 | my @imports = (); 42 | my @other = (); 43 | my $idx = 0; 44 | while( $idx <= $#{$list} ) { 45 | my $item = $list->[$idx]; 46 | 47 | if( defined $item and $item eq 'import' ) { 48 | push @imports, @{ $list->[ $idx + 1 ] }; 49 | $idx++; 50 | } 51 | else { 52 | push @other, $item; 53 | } 54 | 55 | $idx++; 56 | } 57 | 58 | @$list = @other; 59 | 60 | return @imports; 61 | } 62 | 63 | #line 137 64 | 65 | sub import_extra { } 66 | 67 | #line 167 68 | 69 | sub builder { 70 | return Test::Builder->new; 71 | } 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /lib/SSH/Batch.pm: -------------------------------------------------------------------------------- 1 | # vim:set ft=perl ts=4 sw=4 et 2 | 3 | package SSH::Batch; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | our $VERSION = '0.030'; 9 | 10 | 1; 11 | __END__ 12 | 13 | =encoding utf-8 14 | 15 | =head1 NAME 16 | 17 | SSH::Batch - Cluster operations based on parallel SSH, set and interval arithmetic 18 | 19 | =head1 VERSION 20 | 21 | This document describes SSH::Batch 0.030 released on 8 November 2015. 22 | 23 | =head1 SYNOPSIS 24 | 25 | The following scripts are provided: 26 | 27 | =over 28 | 29 | =item fornodes 30 | 31 | Expand patterns to machine host list. 32 | 33 | $ cat > ~/.fornodesrc 34 | ps=blah.ps.com bloo.ps.com boo[2-25,32,41-70].ps.com 35 | as=ws[1101-1105].as.com 36 | # use set operations to define new sets: 37 | foo={ps} + {ps} * {as} - {ps} / {as} 38 | bar = foo.com bar.org \ 39 | bah.cn \ 40 | baz.com 41 | ^D 42 | 43 | $ fornodes 'api[02-10].foo.bar.com' 'boo*.ps.com' 44 | $ fornodes 'tq[ab-ac].[1101-1105].foo.com' 45 | $ fornodes '{ps} + {as} - ws1104.as.com' # set union and subtraction 46 | $ fornodes '{ps} * {as}' # set intersect 47 | 48 | =item atnodes 49 | 50 | Run command on clusters. (atnodes calls fornodes internally.) 51 | 52 | # run a command on the specified servers: 53 | $ atnodes $'ps -fe|grep httpd' 'ws[1101-1105].as.com' 54 | 55 | # multiple-arg command requires "--": 56 | $ atnodes ls /opt/ -- '{ps} + {as}' 'localhost' 57 | 58 | # or use single arg command: 59 | $ atnodes 'ls /opt/' '{ps} + {as}' 'localhost' # ditto 60 | 61 | # specify a different user name and SSH server port: 62 | $ atnodes hostname '{ps}' -u agentz -p 12345 63 | 64 | # use -w to prompt for password if w/o SSH key (no echo back) 65 | $ atnodes hostname '{ps}' -u agentz -w 66 | 67 | # or prompt for password if both login and sudo are required... 68 | $ atnodes 'sudo apachectl restart' '{ps}' -w 69 | 70 | # or prompt for password for sudo only... 71 | $ atnodes 'sudo apachectl restart' '{ps}' -W 72 | 73 | # run sudo command if tty required... 74 | $ atnodes -tty 'sudo apachectl restart' '{ps}' 75 | 76 | # or specify a timeout: 77 | $ atnodes 'ping foo.com' '{ps}' -t 3 78 | 79 | =item tonodes 80 | 81 | Upload local files/directories to remote clusters 82 | 83 | $ tonodes /tmp/*.inst -- '{as}:/tmp/' 84 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt 85 | 86 | # use rsync instead of scp: 87 | $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync 88 | 89 | $ tonodes -r /opt /bin/* -- 'ws[1101-1102].foo.com' 'bar.com' :/foo/bar/ 90 | 91 | =item key2nodes 92 | 93 | Push the SSH public key (or generate one if not any) to the remote clusters. 94 | 95 | $ key2nodes 'ws[1101-1105].as.com' 96 | 97 | =back 98 | 99 | =head1 DESCRIPTION 100 | 101 | System administration (sysadmin) is also part of my C<$work>. Playing with a (big) bunch of machines without a handy tool is painful. So I refactored some of our old scripts and hence this module. 102 | 103 | This is a high-level abstraction over the powerful L module. A bunch of handy scripts are provided to simplify big cluster operations: L, L, L, and L. 104 | 105 | C allows you to name your clusters using variables and interval/set syntax in your F<~/.fornodesrc> config file (or a different file name specified by the C environment). For instance: 106 | 107 | $ cat ~/.fornodesrc 108 | A=foo[01-03].com bar.org 109 | B=bar.org baz[a-b,d,e-g].cn foo02.com 110 | C={A} * {B} 111 | D={A} - {B} 112 | 113 | where cluster C is the intersection set of cluster C and C while C is the sef of machines that are in C but not in C. 114 | 115 | And then you can query machine host list by using C's L script: 116 | 117 | $ fornodes '{C}' 118 | bar.org foo02.com 119 | 120 | $ fornodes '{D}' 121 | foo01.com foo03.com 122 | 123 | $ fornodes blah.com '{C} + {D}' 124 | bar.org blah.com foo01.com foo02.com foo03.com 125 | 126 | It's always best practice to B like C<+>, C<->, C<*>, and C, so as to allow these characters (notably the dash C<->) in your host names, as in: 127 | 128 | $ fornodes 'foo-bar-[a-d].com - foo-bar-c.com' 129 | foo-bar-a.com foo-bar-b.com foo-bar-d.com 130 | 131 | for the ranges like C<[a-z]>, there's also an alternative syntax: 132 | 133 | [a..z] 134 | 135 | To exclude some discrete values from certain range, you need set subtration: 136 | 137 | foo[1-100].com - foo[32,56].com 138 | 139 | or equivalently 140 | 141 | foo[1-31,33-55,57-100].com 142 | 143 | L could be very handy in shell programming. For example, to test the 80 port HTTP service of a cluster C, simply put 144 | 145 | $ for node in `fornodes '{A}'`; \ 146 | do curl "http://$node:80/blah'; \ 147 | done 148 | 149 | Also, other scripts in this module, like L, L, and L also call fornodes internally so that you can use the cluster spec syntax in those scripts' command line as well. 150 | 151 | L meets the common requirement of running a command on a remote cluster. For example: 152 | 153 | # at the concurrency level of 6: 154 | atnodes 'ls -lh' '{A} + {B}' my.more.com -c 6 155 | 156 | Or upload a local file to the remote cluster: 157 | 158 | tonodes ~/my.tar.gz '{A} / {B}' :/tmp/ 159 | 160 | or multiple files as well as some directories: 161 | 162 | tonodes -r ~/mydir ~/mydir2/*.so -- foo.com bar.cn :~/ 163 | 164 | It's also possible to use wildcards in the cluster spec expression, as in 165 | 166 | atnodes 'ls ~' 'api??.*.com' 167 | 168 | where L will match the pattern C against the "universal set" consisting of those hosts appeared in F<~/fornodesrc> and those host names apeared before this pattern on the command line (if any). Note that only C (match any character) and C<*> (match 0 or more characters) are supported here. 169 | 170 | There's also a L script to push SSH public keys to remote machines ;) 171 | 172 | =head1 TIPS 173 | 174 | There's some extra tips found in our own's everyday use: 175 | 176 | =over 177 | 178 | =item Running sudo commands 179 | 180 | Often, we want to run commands requiring root access, such as when installing 181 | software packages on remote machines. So you'll have to tell L to 182 | prompt for your password: 183 | 184 | $ atnodes 'sudo yum install blah' '{my_cluster}' -w 185 | 186 | Then you'll be prompted by the C prompt after which you enter your 187 | remote password (with echo back turned off). 188 | 189 | Because the remote F might be smart enough to "remember" the sudo password 190 | for a (small) amount of time, immediate subsequent "sudo" might omit the C<-w> option, as in 191 | 192 | $ atnodes 'sudo mv ~/foo /usr/local/bin/' {my_cluster} 193 | 194 | But remember, you can use I just for a I amount of 195 | time ;) 196 | 197 | If you see the following error message while doing sudo with L 198 | 199 | sudo: sorry, you must have a tty to run sudo 200 | 201 | then you should add option -tty, or you can probably comment out the "Defaults requiretty" line in your server's F file (best just to do this for your own account). 202 | 203 | =item Passing custom options to the underlying C 204 | 205 | By default, C relies on L to locate the OpenSSH client executable "ssh". But you can define the C environment to specify the command explicitly. You can use the C<-ssh> option to override it further. (The L script also supports the C environment.) 206 | 207 | Note that to specify your own "ssh" is also a way to pass more options to the underlying OpenSSH client executable when using C: 208 | 209 | $ cat > ~/bin/myssh 210 | #!/bin/sh 211 | # to enable X11 forwarding: 212 | exec ssh -X "$@" 213 | ^D 214 | 215 | $ chmod +x ~/bin/myssh 216 | 217 | $ export SSH_BATCH_SSH_CMD=~/bin/myssh 218 | $ atnodes 'ls -lh' '{my_cluster_name}' 219 | 220 | It's important to use "exec" in your own ssh wrapper script, or you may see C hangs. 221 | 222 | This trick also works for the L script. 223 | 224 | =item Use wildcard for cluster expressions to save typing 225 | 226 | Wildcards in cluster spec could save a lot of typing. Say, if you have 227 | C appeared in your F<~/.fornodesrc> file: 228 | 229 | $ cat ~/.fornodesrc 230 | MyCluster=api[01-22].foo.bar.baz.bah.com.cn 231 | 232 | then in case you want to refer to the C node alone on the command line, you can just say C, or C, or something more specific. 233 | 234 | But use wildcards with care. You may have nodes that you don't want in your 235 | resulting host list. So it's best practice to use L<-l> option when you use 236 | wildcards with L or L, as in 237 | 238 | $ atnodes 'rm -rf /opt/blah' 'api10*' -l 239 | 240 | So that L will just echos out the exact host list that it would 241 | operate on but without doing anything. (It's effectively a "dry-run".) 242 | After checking, you can safely remove the C<-l> option and go on. 243 | 244 | =item Specify a different ssh port or user name. 245 | 246 | You may have already learned that you can use the C<-u> and C<-p> options to specify a non-default user account or SSH port. But it's also possible and often more convenient to put it as part of your cluster spec expression, either in F<~/.fornodesrc> or on the command line, as in 247 | 248 | $ cat > ~/.fornodesrc 249 | # cluster A uses the default user name: 250 | A=foo[01-25].com 251 | # cluster B uses the non-default user name "jim" and a port 12345 252 | B=jim@foo[26-28].com:12345 253 | 254 | $ atnodes 'ls -lh' '{B} + bob@bar[29-31].org:5678' 255 | 256 | It's also possible to specify a different rc config file than F<~/.fornodesrc> via the environment variable C. For example, 257 | 258 | export SSH_BATCH_RC=/opt/my-fornodes-rc 259 | 260 | then the file F will be used instead of the default F<~/.fornodesrc> file. 261 | 262 | =item Use C<-L> to help grepping the outputs by hostname 263 | 264 | When managing hundreds or even thousands of machines, it's often more 265 | convenient to C over the outputs of L or L by 266 | host names. The C<-L> option makes L and L to prefixing 267 | every output lines of the remote commands (if any) by the host name. As in 268 | 269 | $ atnodes 'top -b|head -n5' '{my_big_cluster}' -L > out.txt 2>&1 270 | $ grep 'some.specific.host.com' out.txt 271 | 272 | =item Specify a timeout to prevent hanging 273 | 274 | It's often wise to specify a timeout for SSH operations. For example, 275 | if there's 3 sec of network traffic silence, the following command will 276 | quit with an error message printed: 277 | 278 | $ atnodes -t 3 'sleep 4' {my_cluster} 279 | 280 | =item Limit the bandwith used by L to be firewall-friendly 281 | 282 | You can use the C<-b> option to tell L to use limited bandwidth 283 | if your intranet's Firewall is paranoid about your bandwidth use: 284 | 285 | $ tonodes my_big_file {my_cluster}:/tmp/ -b 8000 286 | 287 | where C<8000> is in the unit of Kbits/sec, so it will not transfer 288 | faster than 1 MByte/sec. 289 | 290 | =item Avoid logging manually for the first time 291 | 292 | When you use L or L to access remote servers 293 | that you have never logged in manually, you would probably see the 294 | following errors: 295 | 296 | ===================== foo.com ===================== 297 | Failed to spawn command. 298 | 299 | ERROR: unable to establish master SSH connection: the authenticity of the target host can't be established, try loging manually first 300 | 301 | A work-around is using "ssh" to login to that C machine 302 | manually and then try L or L again. 303 | 304 | Another nicer work-around is to pass the C<-o 'StrictHostKeyChecking=no'> option to the underlying F executable used by C. 305 | Here's a quick HOW-TO: 306 | 307 | $ cat > ~/bin/myssh 308 | #!/bin/sh 309 | # to disable StrictHostKeyChecking 310 | exec ssh -o 'StrictHostKeyChecking=no' "$@" 311 | ^D 312 | 313 | $ chmod +x ~/bin/myssh 314 | 315 | $ export SSH_BATCH_SSH_CMD=~/bin/myssh 316 | 317 | # then we try again 318 | $ key2nodes foo.com 319 | $ atnodes 'hostname' foo.com 320 | 321 | =back 322 | 323 | =head1 PREREQUISITES 324 | 325 | This module uses L behind the scene, so it requires the OpenSSH I executable (usually spelled "ssh") with multiplexing support (at least OpenSSH 4.1). To check your C version, use the command: 326 | 327 | $ ssh -v 328 | 329 | On my machine, it echos 330 | 331 | OpenSSH_4.7p1 Debian-8ubuntu1.2, OpenSSL 0.9.8g 19 Oct 2007 332 | usage: ssh [-1246AaCfgKkMNnqsTtVvXxY] [-b bind_address] [-c cipher_spec] 333 | [-D [bind_address:]port] [-e escape_char] [-F configfile] 334 | [-i identity_file] [-L [bind_address:]port:host:hostport] 335 | [-l login_name] [-m mac_spec] [-O ctl_cmd] [-o option] [-p port] [-R [bind_address:]port:host:hostport] [-S ctl_path] 336 | [-w local_tun[:remote_tun]] [user@]hostname [command] 337 | 338 | There's no spesial requirement on the server side ssh service. Even a non-OpenSSH server-side deamon should work as well. 339 | 340 | =head1 INSTALLATION 341 | 342 | perl Makefile.PL 343 | make 344 | make test 345 | sudo make install 346 | 347 | Win32 users should replace "make" with "nmake". 348 | 349 | =head1 CODE REPOSITORY 350 | 351 | You can always get the latest C source from its public Git repository: 352 | 353 | L 354 | 355 | If you have a branch for me to pull, please let me know ;) 356 | 357 | =head1 TODO 358 | 359 | =over 360 | 361 | =item * 362 | 363 | Cache the parsing and evaluation results of the config file F<~/.fornodesrc> 364 | to somewhere like the fiel F<~/.fornodesrc.cached>. 365 | 366 | =item * 367 | 368 | Abstract the duplicate code found in the scripts to a shared .pm file. 369 | 370 | =item * 371 | 372 | Add the F script to help downloading files from the remote 373 | clusters to local file system (maybe grouped by host name). 374 | 375 | =item * 376 | 377 | Add the F script to transfer files between clusters through 378 | localhost. 379 | 380 | =back 381 | 382 | =head1 AUTHORS 383 | 384 | =over 385 | 386 | =item * 387 | 388 | Zhang "agentzh" Yichun (章亦春) C<< >> 389 | 390 | =item * 391 | 392 | Liseen Wan (万珣新) C<< >> 393 | 394 | =back 395 | 396 | =head1 COPYRIGHT & LICENSE 397 | 398 | This module as well as its programs are licensed under the BSD License. 399 | 400 | Copyright (C) 2009-2015, Yichun "agentzh" Zhang (章亦春). All rights reserved. 401 | 402 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 403 | 404 | =over 405 | 406 | =item * 407 | 408 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 409 | 410 | =item * 411 | 412 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 413 | 414 | =item * 415 | 416 | Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 417 | 418 | =back 419 | 420 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 421 | 422 | =head1 SEE ALSO 423 | 424 | L, L, L, L, 425 | L, L. 426 | 427 | -------------------------------------------------------------------------------- /lib/SSH/Batch/ForNodes.pm: -------------------------------------------------------------------------------- 1 | # vim:set ft=perl ts=4 sw=4 et 2 | 3 | package SSH::Batch::ForNodes; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | our $VERSION = '0.030'; 9 | 10 | use Set::Scalar; 11 | use File::HomeDir; 12 | 13 | sub clear_universe (); 14 | sub init_rc (); 15 | sub load_rc ($$); 16 | sub parse_line ($$); 17 | sub parse_expr ($); 18 | sub parse_term ($); 19 | sub parse_atom ($); 20 | sub expand_seg ($@); 21 | sub expand_wildcards ($); 22 | 23 | my $RangePat = qr/\w+(?:(?:-|\.\.)\w+)?/; 24 | my %Vars; 25 | our $HostUniverse = Set::Scalar->new; 26 | 27 | sub clear_universe () { 28 | $HostUniverse->empty; 29 | } 30 | 31 | sub init_rc () { 32 | my $rcfile = $ENV{SSH_BATCH_RC} || q(); 33 | if(! $rcfile){ 34 | my $home = $ENV{SSH_BATCH_HOME} || File::HomeDir->my_home; 35 | if (!defined $home || !-d $home) { 36 | die "Can't find the home for the current user.\n"; 37 | } 38 | $rcfile = "$home/.fornodesrc"; 39 | } 40 | 41 | # auto create $rcfile if $rcfile not exists 42 | if (! -e $rcfile) { 43 | open my $rc, '>', $rcfile or 44 | die "Can't auto create $rcfile: $!\n"; 45 | close $rc; 46 | } 47 | 48 | open my $rc, $rcfile or 49 | die "Can't open $rcfile for reading: $!\n"; 50 | load_rc($rc, $rcfile); 51 | close $rc; 52 | #return ($rc, $rcfile); 53 | } 54 | 55 | sub load_rc ($$) { 56 | my ($rc, $rcfile) = @_; 57 | my $accum_ln; 58 | while (<$rc>) { 59 | s/\#.*//; 60 | next if /^\s*$/; 61 | chomp; 62 | if (s/\\\s*$//s) { 63 | $accum_ln .= " $_"; 64 | next; 65 | } 66 | if (defined $accum_ln) { 67 | parse_line("$accum_ln $_", $rcfile); 68 | undef $accum_ln; 69 | next; 70 | } 71 | parse_line($_, $rcfile); 72 | } 73 | } 74 | 75 | sub parse_line ($$) { 76 | local *_ = \($_[0]); 77 | my $rcfile = $_[1]; 78 | if (/^\s*([^=\s]*)\s*=\s*(.*)/) { 79 | my ($var, $def) = ($1, $2); 80 | if ($var !~ /^\w[-\.\w]*$/) { 81 | die "Invalid variable name in $rcfile, line $.: ", 82 | "$var\n"; 83 | } 84 | my $set; 85 | eval { 86 | $set = parse_expr($def); 87 | }; 88 | if ($@) { 89 | die "Failed to parse the variable $var\'s value in $rcfile, ", 90 | "line $.: $@"; 91 | } else { 92 | if (defined $Vars{$var}) { 93 | die "Variable redefinition in $rcfile line $.: $_\n"; 94 | } 95 | $Vars{$var} = $set; 96 | } 97 | } else { 98 | die "Syntax error in $rcfile, line $.: $_\n"; 99 | } 100 | } 101 | 102 | sub parse_expr ($) { 103 | local *_ = \($_[0]); 104 | 105 | # trim 106 | s/(?:^\s+|\s+$)//gs; 107 | 108 | my @toplevel; 109 | while (1) { 110 | if (/\G \s* (?<= [\}\)\s] ) ([-+*\/]) (?= [\{\(\s] ) \s*/gcx) { 111 | push @toplevel, $1; 112 | } elsif (/\G \{ .*? \} /gcx) { 113 | push @toplevel, $&; 114 | } elsif (/\G \S+ /gcx) { 115 | push @toplevel, $&; 116 | } elsif (/\G \s+ /gcx) { 117 | push @toplevel, '+'; 118 | } else { 119 | last; 120 | } 121 | } 122 | my $expect_term = 1; 123 | for my $raw_op (@toplevel) { # op would be either operands or operators 124 | my $op = $raw_op; 125 | 126 | if ($op =~ /^[-+*\/]$/) { 127 | if ($expect_term) { 128 | die "Expecting terms but found operator $op.\n"; 129 | } 130 | $expect_term = 1; 131 | next; 132 | } 133 | if (!$expect_term) { 134 | die "Expecting operators but found term $op\n"; 135 | } 136 | $expect_term = 0; 137 | eval { 138 | $raw_op = parse_term($op); 139 | }; 140 | if ($@) { 141 | die $@; 142 | } 143 | } 144 | my @lower; 145 | while (@toplevel > 1) { 146 | my $a = shift @toplevel; 147 | my $op = shift @toplevel; 148 | if ($op eq '+') { 149 | push @lower, $a, $op; 150 | #unshift @toplevel, $a + $b; 151 | } elsif ($op eq '-') { 152 | push @lower, $a, $op; 153 | #unshift @toplevel, $a - $b; 154 | } elsif ($op eq '*') { 155 | my $b = shift @toplevel; 156 | unshift @toplevel, $a * $b; 157 | } elsif ($op eq '/') { 158 | my $b = shift @toplevel; 159 | unshift @toplevel, $a / $b; 160 | } else { 161 | die "Invalid operator : [$op]\n"; 162 | } 163 | } 164 | if (@toplevel) { 165 | push @lower, @toplevel; 166 | } 167 | while (@lower > 1) { 168 | my $a = shift @lower; 169 | my $op = shift @lower; 170 | my $b = shift @lower; 171 | 172 | if ($op eq '+') { 173 | unshift @lower, $a + $b; 174 | } elsif ($op eq '-') { 175 | unshift @lower, $a - $b; 176 | } else { 177 | die "Unexpected operator: [$op]\n"; 178 | } 179 | } 180 | return @lower ? $lower[0] : Set::Scalar->new; 181 | } 182 | 183 | sub parse_term ($) { 184 | local *_ = \($_[0]); 185 | if (/^ \{ ( [^}\s]* ) \} $/x) { 186 | my $var = $1; 187 | if ($var !~ /^\w[-\.\w]*$/) { 188 | die "Invalid variable name in term $_: $var\n"; 189 | } 190 | my $set = $Vars{$var}; 191 | if (!defined $set) { 192 | die "Variable $var not defined.\n"; 193 | } 194 | return $set; 195 | } 196 | if (/[{}]/) { 197 | die "Invalid variable reference syntax: $_\n"; 198 | } 199 | return parse_atom($_); 200 | } 201 | 202 | sub parse_atom ($) { 203 | local *_ = \($_[0]); 204 | my @segs; 205 | while (1) { 206 | if (/ \G \[ ( [^\]]* ) \] /xgc) { 207 | my $range = $1; 208 | #warn "Range: $range\n"; 209 | if ($range !~ m/^$RangePat(?:\s*,\s*$RangePat)*$/) { 210 | die "Bad range: [$range]\n"; 211 | } 212 | my @ranges = split /,/, $range; 213 | my @num; 214 | for my $range (@ranges) { 215 | my ($a, $b) = split /(?:-|\.\.)/, $range; 216 | #if (defined $b && ($a =~ /\D/ || $b =~ /\D/) && length $a ne length $b) { 217 | #die "End points are not of equal lengths in the host range: $a-$b\n"; 218 | #} 219 | push @num, defined $b ? $a..$b : $a; 220 | #print "@num"; 221 | } 222 | push @segs, \@num; 223 | } elsif (/\G[^\[]+/gc) { 224 | push @segs, [$&]; 225 | next; 226 | } else { 227 | last; 228 | } 229 | } 230 | my $hosts = expand_seg(\@segs); 231 | my $set = Set::Scalar->new; 232 | for my $host (@$hosts) { 233 | #warn "Host: $host\n"; 234 | if ($host =~ /[\*\?]/) { 235 | $set->insert(expand_wildcards($host)); 236 | } else { 237 | #warn "Inserting $host: $host\n"; 238 | $set->insert($host); 239 | $HostUniverse->insert($host); 240 | } 241 | } 242 | return $set; 243 | } 244 | 245 | sub expand_seg ($@) { 246 | my ($list, $prefixes) = @_; 247 | my $cur = shift @$list; 248 | return $prefixes unless defined $cur; 249 | my @new_prefixes; 250 | if (!$prefixes) { 251 | for my $alt (@$cur) { 252 | push @new_prefixes, $alt; 253 | } 254 | } else { 255 | for my $prefix (@$prefixes) { 256 | for my $alt (@$cur) { 257 | push @new_prefixes, $prefix . $alt; 258 | } 259 | } 260 | } 261 | return expand_seg($list, \@new_prefixes); 262 | } 263 | 264 | sub expand_wildcards ($) { 265 | my $pat = quotemeta $_[0]; 266 | $pat =~ s/\\\*/.*?/g; 267 | $pat =~ s/\\\?/./g; 268 | my @retvals; 269 | while (defined(my $host = $HostUniverse->each)) { 270 | if ($host =~ /^$pat$/) { 271 | push @retvals, $host; 272 | } 273 | } 274 | return @retvals; 275 | } 276 | 277 | 1; 278 | __END__ 279 | 280 | =encoding utf-8 281 | 282 | =head1 NAME 283 | 284 | SSH::Batch::ForNodes - Expand set arithmetic expression to host list 285 | 286 | =head1 SYNOPSIS 287 | 288 | # below is essential what in the "fornodes" script: 289 | use SSH::Batch::ForNodes; 290 | 291 | SSH::Batch::ForNodes::init_rc(); 292 | # read the config file from env SSH_BATCH_RC or directly ~/.fornodesrc 293 | 294 | my $set = SSH::Batch::ForNodes::parse_expr($expr); 295 | # set is a Set::Scalar instance: 296 | for my $host (sort $set->elements) { 297 | print "$host\n"; 298 | } 299 | 300 | =head1 AUTHORS 301 | 302 | =over 303 | 304 | =item * 305 | 306 | Yichun "agentzh" Zhang (章亦春) C<< >> 307 | 308 | =item * 309 | 310 | Liseen Wan (万珣新) C<< >> 311 | 312 | =back 313 | 314 | =head1 COPYRIGHT & LICENSE 315 | 316 | This module as well as its programs are licensed under the BSD License. 317 | 318 | Copyright (C) 2009-2015, Yichun "agentzh" Zhang (章亦春). All rights reserved. 319 | 320 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 321 | 322 | =over 323 | 324 | =item * 325 | 326 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 327 | 328 | =item * 329 | 330 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 331 | 332 | =item * 333 | 334 | Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 335 | 336 | =back 337 | 338 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 339 | 340 | -------------------------------------------------------------------------------- /t/99-pod-coverage.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | # XXX we need more POD... 4 | my $skip_all = 1; 5 | eval "use Test::Pod::Coverage"; 6 | plan skip_all => "We know we don't have enough POD :(" if $skip_all; 7 | plan skip_all => "Test::Pod::Coverage required for testing POD coverage" if $@; 8 | all_pod_coverage_ok(); 9 | 10 | -------------------------------------------------------------------------------- /t/99-pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | eval "use Test::Pod"; 4 | plan skip_all => "Test::Pod required for testing POD" if $@; 5 | all_pod_files_ok(); 6 | -------------------------------------------------------------------------------- /t/agentzh.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | #use Smart::Comments::JSON '##'; 5 | use IPC::Run3 qw(run3); 6 | #use List::MoreUtils qw( all ); 7 | 8 | delete $ENV{SSH_BATCH_SSH_CMD}; 9 | delete $ENV{SSH_BATCH_LINE_MODE}; 10 | 11 | my $should_skip; 12 | BEGIN { 13 | $should_skip = ! $ENV{SSH_BATCH_TEST_AGENTZH}; 14 | }; 15 | use Test::More $should_skip ? 16 | (skip_all => "Should only be enabled by developers.") : 17 | ('no_plan'); 18 | 19 | sub sh ($) { 20 | my $cmd = shift; 21 | if (system($cmd) != 0) { 22 | die "Failed to execute $cmd. Abort.\n"; 23 | } 24 | } 25 | 26 | sub fornodes (@) { 27 | my ($out, $err); 28 | run3 [$^X, 'bin/fornodes', @_], \undef, \$out, \$err; 29 | if ($? != 0) { 30 | warn "fornodes returns non-zero status: ", $? >> 8, "\n"; 31 | } 32 | if ($err) { 33 | warn $err; 34 | } 35 | chomp $out; 36 | my @hosts = split / /ms, $out; 37 | return \@hosts; 38 | } 39 | 40 | sub tonodes (@) { 41 | my ($out, $err); 42 | run3 [$^X, 'bin/tonodes', @_], \undef, \$out, \$out; 43 | if ($? != 0) { 44 | warn "tonodes returns non-zero status: ", $? >> 8, "\n"; 45 | } 46 | if ($err) { 47 | warn $err; 48 | } 49 | my @outs = split /^====+ [^=]+ ===+$/ms, $out; 50 | shift @outs; 51 | return \@outs; 52 | } 53 | 54 | sub tonodes2 (@) { 55 | my ($out, $err); 56 | run3 [$^X, 'bin/tonodes', @_], \undef, \$out, \$out; 57 | if ($? != 0) { 58 | warn "tonodes returns non-zero status: ", $? >> 8, "\n"; 59 | } 60 | if ($err) { 61 | warn $err; 62 | } 63 | return $out; 64 | } 65 | 66 | sub atnodes (@) { 67 | my ($out, $err); 68 | run3 [$^X, 'bin/atnodes', @_], \undef, \$out, \$out; 69 | if ($? != 0) { 70 | warn "atnodes returns non-zero status: ", $? >> 8, "\n"; 71 | } 72 | if ($err) { 73 | warn $err; 74 | } 75 | my @outs = split /^====+ [^=]+ ===+$/ms, $out; 76 | shift @outs; 77 | return \@outs; 78 | } 79 | 80 | sub atnodes2 (@) { 81 | my ($out, $err); 82 | run3 [$^X, 'bin/atnodes', @_], \undef, \$out, \$out; 83 | if ($? != 0) { 84 | warn "atnodes returns non-zero status: ", $? >> 8, "\n"; 85 | } 86 | if ($err) { 87 | warn $err; 88 | } 89 | return $out; 90 | } 91 | 92 | sub gen_local_tree () { 93 | if (-d 't/tmp') { 94 | sh 'rm -rf t/tmp'; 95 | } 96 | sh 'mkdir -p t/tmp'; 97 | sh 'touch t/tmp/a.txt'; 98 | sh 'touch t/tmp/b.txt'; 99 | sh 'touch t/tmp/README'; 100 | sh 'mkdir -p t/tmp/foo/bar'; 101 | sh 'touch t/tmp/foo/INSTALL'; 102 | } 103 | 104 | sub cleanup_remote_tree ($) { 105 | my $count = shift; 106 | my $outs = atnodes('rm -rf /tmp/tmp', '{tq}'); 107 | is scalar(@$outs), $count, 'all hosts generate outputs'; 108 | for my $out (@$outs) { 109 | like $out, qr/^\s*$/, 'rm successfuly'; 110 | } 111 | $outs = atnodes('ls /tmp/tmp', '{tq}'); 112 | is scalar(@$outs), $count, 'all hosts generate outputs'; 113 | ## outs: @$outs 114 | for my $out (@$outs) { 115 | is $out, "\nRemote command returns status code 1.\nls: /tmp/tmp: No such file or directory\n\n", 116 | 'directory already removed'; 117 | } 118 | } 119 | 120 | my $hosts = fornodes('{tq}'); 121 | my $count = @$hosts; 122 | ok $count > 3, "more than 3 hosts in {tq} (found $count)"; 123 | 124 | # atnodes: exit 1 125 | { 126 | my $out = atnodes2('exit 1', '{tq}', '-L'); 127 | my @lines = split /\n/, $out; 128 | my $i = 0; 129 | for my $host (@$hosts) { 130 | like $lines[$i++], 131 | qr/^\Q$host\E: Remote command returns status code 1\.$/, 132 | 'line mode works'; 133 | } 134 | } 135 | 136 | # atnodes: multi-line output 137 | { 138 | my $out = atnodes2('echo hello, world; echo hey', '{tq}', '-L'); 139 | my @lines = split /\n/, $out; 140 | my $i = 0; 141 | for my $host (@$hosts) { 142 | like $lines[$i++], 143 | qr/^\Q$host\E: hello, world$/, 144 | 'line mode works'; 145 | like $lines[$i++], 146 | qr/^\Q$host\E: hey$/, 147 | 'line mode works'; 148 | } 149 | } 150 | 151 | # atnodes: single-line 152 | { 153 | my $out = atnodes2('echo', '{tq}', '-L'); 154 | my @lines = split /\n/, $out; 155 | my $i = 0; 156 | for my $host (@$hosts) { 157 | like $lines[$i++], 158 | qr/^\Q$host\E: $/, 159 | 'line mode works'; 160 | } 161 | } 162 | 163 | # atnodes: no output 164 | { 165 | my $out = atnodes2('echo -n', '{tq}', '-L'); 166 | is $out, '', 'no output, no hostname'; 167 | } 168 | 169 | # atnodes: buggy with invalid hosts 170 | { 171 | my $out = atnodes2('hostname', '{buggy}', '-L'); 172 | open my $in, '<', \$out; 173 | my $i = 0; 174 | my $fail_count = 0; 175 | while (<$in>) { 176 | chomp; 177 | next if /^ssh:.*?: Name or service not known\r?$/s; 178 | if (/^\S+: ERROR: /) { 179 | $fail_count++; 180 | next; 181 | } 182 | my $host = $hosts->[$i++]; 183 | my $hostname; 184 | if ($host =~ /^\w+/) { 185 | $hostname = $&; 186 | } 187 | like $_, qr/^\Q$host\E: $hostname$/, 'hostname works'; 188 | } 189 | close $in; 190 | cmp_ok $fail_count, '>', 1, 'fail count okay'; 191 | ## out: $out 192 | } 193 | 194 | # atnodes: buggy with timeout hosts 195 | { 196 | my $out = atnodes2('hostname', '-t', 2, '{timeout}', '-L'); 197 | open my $in, '<', \$out; 198 | my $i = 0; 199 | my $fail_count = 0; 200 | while (<$in>) { 201 | chomp; 202 | next if /^ssh:.*?: Name or service not known\r?$/s; 203 | if (/^\S+: ERROR: .*?timed out/) { 204 | $fail_count++; 205 | next; 206 | } 207 | my $host = $hosts->[$i++]; 208 | my $hostname; 209 | if ($host =~ /^\w+/) { 210 | $hostname = $&; 211 | } 212 | like $_, qr/^\Q$host\E: $hostname$/, 'hostname works'; 213 | } 214 | close $in; 215 | cmp_ok $fail_count, '>=', 1, 'fail count okay'; 216 | ## out: $out 217 | } 218 | 219 | # tonodes: buggy with invalid hosts 220 | { 221 | my $out = tonodes2('t/agentzh.t', '{buggy}:/tmp/', '-L'); 222 | open my $in, '<', \$out; 223 | my $i = 0; 224 | my $fail_count = 0; 225 | while (<$in>) { 226 | chomp; 227 | next if /^ssh:.*?: Name or service not known\r?$/s; 228 | if (/^\S+: ERROR: /) { 229 | $fail_count++; 230 | next; 231 | } 232 | } 233 | close $in; 234 | cmp_ok $fail_count, '>', 1, 'fail count okay'; 235 | ## out: $out 236 | } 237 | 238 | # tonodes: buggy with timeout hosts 239 | { 240 | my $out = tonodes2('t/agentzh.t', '-t', 2, '{timeout}:/tmp/', '-L'); 241 | open my $in, '<', \$out; 242 | my $i = 0; 243 | my $fail_count = 0; 244 | while (<$in>) { 245 | chomp; 246 | if (/^\S+: ERROR: .*?timed out/) { 247 | $fail_count++; 248 | } 249 | } 250 | close $in; 251 | cmp_ok $fail_count, '>=', 1, 'fail count okay'; 252 | ## out: $out 253 | } 254 | 255 | #exit; 256 | 257 | cleanup_remote_tree($count); 258 | my $outs = tonodes('-r', '-rsync', 't/tmp', '--', '{tq}', ':/tmp/'); 259 | for my $out (@$outs) { 260 | is $out, "\n\n", 'transfer successfuly'; 261 | } 262 | 263 | $outs = atnodes('ls /tmp/tmp|sort', '{tq}'); 264 | is scalar(@$outs), $count, 'all hosts generate outputs'; 265 | ## outs: @$outs 266 | for my $out (@$outs) { 267 | is $out, "\nREADME\na.txt\nb.txt\nfoo\n\n", 268 | 'only specified files uploaded'; 269 | } 270 | 271 | cleanup_remote_tree($count); 272 | gen_local_tree(); 273 | 274 | $outs = tonodes('-r', 't/tmp', '{tq}:/tmp/'); 275 | is scalar(@$outs), $count, 'all hosts generate outputs'; 276 | 277 | $outs = atnodes('ls /tmp/tmp|sort', '{tq}'); 278 | is scalar(@$outs), $count, 'all hosts generate outputs'; 279 | for my $out (@$outs) { 280 | is $out, "\nREADME\na.txt\nb.txt\nfoo\n\n", 'level 1 files expected'; 281 | } 282 | 283 | $outs = atnodes('ls /tmp/tmp/foo|sort', '{tq}'); 284 | is scalar(@$outs), $count, 'all hosts generate outputs'; 285 | 286 | ## outs: @$outs 287 | for my $out (@$outs) { 288 | is $out, "\nINSTALL\nbar\n\n", 'level 1 files expected'; 289 | } 290 | 291 | cleanup_remote_tree($count); 292 | 293 | $outs = tonodes('t/tmp', '{tq}:/tmp/', '-v'); 294 | for my $out (@$outs) { 295 | is $out, "\n", 'transfer successfuly'; 296 | } 297 | 298 | $outs = atnodes('ls /tmp/tmp', '{tq}'); 299 | is scalar(@$outs), $count, 'all hosts generate outputs'; 300 | ## outs: @$outs 301 | for my $out (@$outs) { 302 | is $out, "\nRemote command returns status code 1.\nls: /tmp/tmp: No such file or directory\n\n", 'no -r no cp'; 303 | } 304 | 305 | cleanup_remote_tree($count); 306 | 307 | $outs = atnodes('mkdir /tmp/tmp', '{tq}'); 308 | is scalar(@$outs), $count, 'all hosts generate outputs'; 309 | 310 | $outs = tonodes('t/tmp/a.txt', 't/tmp/b.txt', '--', '{tq}', ':/tmp/tmp/'); 311 | for my $out (@$outs) { 312 | is $out, "\n\n", 'transfer successfuly'; 313 | } 314 | 315 | $outs = atnodes('ls /tmp/tmp|sort', '{tq}'); 316 | is scalar(@$outs), $count, 'all hosts generate outputs'; 317 | ## outs: @$outs 318 | for my $out (@$outs) { 319 | is $out, "\na.txt\nb.txt\n\n", 'only specified files uploaded'; 320 | } 321 | 322 | cleanup_remote_tree($count); 323 | $outs = atnodes('mkdir /tmp/tmp', '{tq}'); 324 | is scalar(@$outs), $count, 'all hosts generate outputs'; 325 | 326 | $outs = tonodes('t/tmp/*', '--', '{tq}', ':/tmp/tmp/'); 327 | ## outs: @$outs 328 | for my $out (@$outs) { 329 | is $out, "\n\n", 'transfer successfuly'; 330 | } 331 | 332 | $outs = atnodes('ls /tmp/tmp|sort', '{tq}'); 333 | is scalar(@$outs), $count, 'all hosts generate outputs'; 334 | for my $out (@$outs) { 335 | is $out, "\n\n", 'no glob no files'; 336 | } 337 | 338 | $outs = tonodes('-g', 't/tmp/*', '--', '{tq}', ':/tmp/tmp/', '-c', 2, '-v'); 339 | for my $out (@$outs) { 340 | like $out, qr/^\s*$/s, 'transfer successfuly'; 341 | } 342 | 343 | $outs = atnodes('ls /tmp/tmp|sort', '-c', 2, '{tq}'); 344 | is scalar(@$outs), $count, 'all hosts generate outputs'; 345 | ## outs: @$outs 346 | for my $out (@$outs) { 347 | is $out, "\nREADME\na.txt\nb.txt\n\n", 'only specified files uploaded'; 348 | } 349 | 350 | warn "DONE.\n"; 351 | -------------------------------------------------------------------------------- /t/atnodes.pm: -------------------------------------------------------------------------------- 1 | package t::atnodes; 2 | 3 | use Test::Base -Base; 4 | use IPC::Run3 (); 5 | use FindBin; 6 | 7 | our @EXPORT = qw( run_tests ); 8 | 9 | if (!-d 't/tmp') { 10 | mkdir 't/tmp'; 11 | } 12 | $ENV{LC_ALL} = 'C'; 13 | delete $ENV{SSH_BATCH_SSH_CMD}; 14 | delete $ENV{SSH_BATCH_LINE_MODE}; 15 | $ENV{SSH_BATCH_HOME} = "$FindBin::Bin/tmp"; 16 | #warn $ENV{SSH_BATCH_HOME}; 17 | my $RcFile = $ENV{SSH_BATCH_HOME} . '/.fornodesrc'; 18 | 19 | my $is_linux = ($^O =~ /linux/i); 20 | 21 | sub run_tests () { 22 | for my $block (blocks()) { 23 | run_test($block); 24 | } 25 | } 26 | 27 | sub write_rc (@) { 28 | open my $out, ">$RcFile" or 29 | die "Failed to open $RcFile for writing: $!\n"; 30 | print $out @_; 31 | close $out; 32 | } 33 | 34 | sub run_test ($) { 35 | my $block = shift; 36 | my $name = $block->name; 37 | 38 | if (defined $block->linux_only && ! $is_linux) { 39 | diag "$name - Tests skipped on $^O\n"; 40 | for (1..3) { 41 | pass("tests skipped on $^O\n"); 42 | } 43 | return; 44 | } 45 | 46 | my $prev_home; 47 | if (defined $block->no_home) { 48 | $prev_home = $ENV{SSH_BATCH_HOME}; 49 | $ENV{SSH_BATCH_HOME} = '/foo/bar/baz/32rdssfsd32'; 50 | $RcFile = $ENV{SSH_BATCH_HOME} . '/.fornodesrc'; 51 | } 52 | 53 | my $args = $block->args; 54 | if (!defined $args) { 55 | die "$name - No --- args specified.\n"; 56 | } 57 | chomp $args; 58 | if (!defined $args) { 59 | die "$name - No --- args specified.\n"; 60 | } 61 | if (defined $block->rc) { 62 | write_rc($block->rc); 63 | } elsif (defined $block->no_rc) { 64 | unlink $RcFile; 65 | } 66 | my $cmd = ("\"$^X\" bin/atnodes $args"); 67 | my ($in, $out, $err); 68 | IPC::Run3::run3 $cmd, \$in, \$out, \$err; 69 | if (defined $block->status) { 70 | #warn "status: $?\n"; 71 | if ($block->status == 0) { 72 | is($? >> 8, $block->status, "$name - status ok"); 73 | } else { 74 | ok($? >> 8, "$name - status ok"); 75 | } 76 | } 77 | if (defined $block->no_home) { 78 | $ENV{SSH_BATCH_HOME} = $prev_home; 79 | $RcFile = $ENV{SSH_BATCH_HOME} . '/.fornodesrc'; 80 | } 81 | if (defined $block->err) { 82 | $err =~ s/\Q$RcFile\E/**RC_FILE_PATH**/g; 83 | is $err, $block->err, "$name - stderr ok"; 84 | } elsif ($err) { 85 | warn $err, "\n"; 86 | } 87 | if (defined $block->out) { 88 | $out =~ s/\Q$RcFile\E/**RC_FILE_PATH**/g; 89 | is $out, $block->out, "$name - stdout ok"; 90 | } 91 | } 92 | 93 | 1; 94 | 95 | -------------------------------------------------------------------------------- /t/atnodes.t: -------------------------------------------------------------------------------- 1 | # vi:filetype= 2 | 3 | use t::atnodes; 4 | 5 | plan tests => 3 * blocks(); 6 | 7 | #no_diff(); 8 | 9 | run_tests(); 10 | 11 | __DATA__ 12 | 13 | === TEST 1: no home 14 | --- no_home 15 | --- args: ls * 16 | --- err 17 | Can't find the home for the current user. 18 | --- out 19 | --- status: 2 20 | 21 | 22 | 23 | === TEST 2: no rc given 24 | --- args: ls * 25 | --- no_rc 26 | --- out 27 | --- status: 0 28 | --- SKIP 29 | 30 | 31 | 32 | === TEST 3: no args given 33 | --- rc 34 | api=api01.foo.com api02.foo.com 35 | --- args: 36 | --- out 37 | --- err 38 | No argument specified. 39 | 40 | USAGE: 41 | 42 | atnodes [OPTIONS] COMMAND... -- HOST_PATTERN... [OPTIONS] 43 | atnodes [OPTIONS] COMMAND HOST_PATTERN... [OPTIONS] 44 | 45 | OPTIONS: 46 | -c Set SSH concurrency limit. (default: 20, 47 | when -tty is on, this setting will no use) 48 | -h Print this help. 49 | -l List the hosts and do nothing else. 50 | -L Use the line-mode output format, i.e., prefixing 51 | every output line with the machine name. 52 | (could be controlled by the env SSH_BATCH_LINE_MODE) 53 | -p Port for the remote SSH service. 54 | -ssh Specify an alternate ssh program. 55 | (This overrides the SSH_BATCH_SSH_CMD environment.) 56 | -t Specify timeout for net traffic. 57 | -u User account for SSH login. 58 | -v Be verbose. 59 | -w Prompt for password (used for both login and sudo, 60 | could be privided by SSH_BATCH_PASSWORD). 61 | -W Prompt for password (just for sudo), 62 | should not be used with -w. 63 | -P Prompt for passphrase (used for login, 64 | could be privided by SSH_BATCH_PASSPHRASE). 65 | -tty Pseudo-tty. 66 | -q Run SSH in quiet mode 67 | --- status: 1 68 | 69 | 70 | 71 | === TEST 4: no command 72 | --- args: -- foo.com 73 | --- out 74 | --- err 75 | No command specified. 76 | --- status: 255 77 | 78 | 79 | 80 | === TEST 5: no expression 81 | --- args: 'ls *' 82 | --- out 83 | --- err 84 | No cluster expression specified. 85 | --- status: 255 86 | 87 | 88 | 89 | === TEST 6: commands & expression 90 | --- args: ls '*' -- foo.com '*.bar.cn' -l -v 91 | --- rc 92 | blah=foo 93 | --- out 94 | --- err 95 | Command: [ls][*] 96 | Cluster expression: foo.com *.bar.cn 97 | Cluster set: foo.com 98 | --- status: 0 99 | 100 | 101 | 102 | === TEST 7: option takes a value error 103 | --- args: ls foo.com -u 104 | --- out 105 | --- err 106 | ERROR: Option -u takes a value. 107 | --- status: 1 108 | 109 | 110 | 111 | === TEST 8: -ssh option 112 | --- args: -ssh foo ls foo.com -l -v 113 | --- out 114 | --- err 115 | Command: [ls] 116 | Using SSH program [foo]. 117 | Cluster expression: foo.com 118 | Cluster set: foo.com 119 | --- status: 0 120 | 121 | 122 | 123 | === TEST 9: -W and -w both show 124 | --- args: -w -W 125 | --- out 126 | --- err 127 | ERROR: Option -w should not be used together with -W. 128 | Use -w to use passowrd for login and sudo, -W for sudo only. 129 | --- status: 1 130 | -------------------------------------------------------------------------------- /t/fornodes.pm: -------------------------------------------------------------------------------- 1 | package t::fornodes; 2 | 3 | use Test::Base -Base; 4 | use IPC::Run3 (); 5 | use FindBin; 6 | 7 | our @EXPORT = qw( run_tests ); 8 | 9 | if (!-d 't/tmp') { 10 | mkdir 't/tmp'; 11 | } 12 | $ENV{LC_ALL} = 'C'; 13 | $ENV{SSH_BATCH_HOME} = "$FindBin::Bin/tmp"; 14 | #warn $ENV{SSH_BATCH_HOME}; 15 | my $RcFile = $ENV{SSH_BATCH_HOME} . '/.fornodesrc'; 16 | 17 | my $is_linux = ($^O =~ /linux/i); 18 | 19 | sub run_tests () { 20 | for my $block (blocks()) { 21 | run_test($block); 22 | } 23 | } 24 | 25 | sub write_rc (@) { 26 | open my $out, ">$RcFile" or 27 | die "Failed to open $RcFile for writing: $!\n"; 28 | print $out @_; 29 | close $out; 30 | } 31 | 32 | sub run_test ($) { 33 | my $block = shift; 34 | my $name = $block->name; 35 | 36 | if (defined $block->linux_only && ! $is_linux) { 37 | diag "$name - Tests skipped on $^O\n"; 38 | for (1..3) { 39 | pass("tests skipped on $^O\n"); 40 | } 41 | return; 42 | } 43 | my $expr = $block->expr; 44 | if (defined $expr) { chomp $expr; } 45 | if (!defined $expr && !defined $block->opts) { 46 | die "Neither --- expr nor --- opts specified.\n"; 47 | } 48 | if (defined $block->rc) { 49 | write_rc($block->rc); 50 | } elsif (defined $block->no_rc) { 51 | unlink $RcFile; 52 | } 53 | my $prev_home; 54 | if (defined $block->no_home) { 55 | $prev_home = $ENV{SSH_BATCH_HOME}; 56 | $ENV{SSH_BATCH_HOME} = '/foo/bar/baz/32rdssfsd32'; 57 | } 58 | my @opts; 59 | if (defined $block->opts) { 60 | @opts = split /\s+/, $block->opts; 61 | } 62 | my @cmd = ($^X, 'bin/fornodes', @opts, defined $expr ? $expr : ()); 63 | my ($in, $out, $err); 64 | IPC::Run3::run3 \@cmd, \$in, \$out, \$err; 65 | if (defined $block->status) { 66 | #warn "status: $?\n"; 67 | if ($block->status == 0) { 68 | is $? >> 8, $block->status, "$name - status ok"; 69 | } else { 70 | ok($? >> 8, "$name - status ok"); 71 | } 72 | } 73 | if (defined $block->no_home) { 74 | $ENV{SSH_BATCH_HOME} = $prev_home; 75 | } 76 | if (defined $block->err) { 77 | $err =~ s/\Q$RcFile\E/**RC_FILE_PATH**/g; 78 | is $err, $block->err, "$name - stderr ok"; 79 | } elsif ($err) { 80 | warn $err, "\n"; 81 | } 82 | if (defined $block->out) { 83 | $out =~ s/^\s+$//s; 84 | $out =~ s/\Q$RcFile\E/**RC_FILE_PATH**/g; 85 | is $out, $block->out, "$name - stdout ok"; 86 | } 87 | } 88 | 89 | 1; 90 | 91 | -------------------------------------------------------------------------------- /t/fornodes.t: -------------------------------------------------------------------------------- 1 | # vi:filetype= 2 | 3 | use t::fornodes; 4 | 5 | plan tests => 3 * blocks(); 6 | 7 | no_diff(); 8 | 9 | run_tests(); 10 | 11 | __DATA__ 12 | 13 | === TEST 1: no home 14 | --- no_home 15 | --- expr: abc 16 | --- err 17 | Can't find the home for the current user. 18 | --- out 19 | --- status: 2 20 | 21 | 22 | 23 | === TEST 2: no rc given 24 | --- expr: foo 25 | --- no_rc 26 | --- out 27 | --- err 28 | Can't open **RC_FILE_PATH** for reading: No such file or directory 29 | --- status: 2 30 | --- SKIP 31 | 32 | 33 | 34 | === TEST 3: no expr given 35 | --- rc 36 | api=api01.foo.com api02.foo.com 37 | --- expr: 38 | --- out 39 | --- err 40 | No argument specified. 41 | 42 | USAGE: 43 | 44 | fornodes [OPTIONS] HOST_PATTERN... [OPTIONS] 45 | 46 | OPTIONS: 47 | -h Print this help 48 | -x Expand the host list output to multiple lines. 49 | --- status: 255 50 | 51 | 52 | 53 | === TEST 4: literal hosts 54 | --- expr: foo.com bar.cn 55 | --- err 56 | --- out 57 | bar.cn foo.com 58 | --- status: 0 59 | 60 | 61 | 62 | === TEST 5: unmatched wildcard ? 63 | --- expr: api?.foo.com 64 | --- out 65 | --- err 66 | --- status: 0 67 | 68 | 69 | 70 | === TEST 6: matched wildcard ? 71 | --- expr: api??.foo.com 72 | --- out 73 | api01.foo.com api02.foo.com 74 | --- err 75 | --- status: 0 76 | 77 | 78 | 79 | === TEST 7: wildcard * 80 | --- expr: api* 81 | --- opts: -x 82 | --- err 83 | --- out 84 | api01.foo.com 85 | api02.foo.com 86 | --- status: 0 87 | 88 | 89 | 90 | === TEST 8: wildcard * with ? 91 | --- expr: api?2.*.com 92 | --- err 93 | --- out 94 | api02.foo.com 95 | --- status: 0 96 | 97 | 98 | 99 | === TEST 9: variable reference 100 | --- expr: {api} 101 | --- err 102 | --- out 103 | api01.foo.com api02.foo.com 104 | --- status: 0 105 | 106 | 107 | 108 | === TEST 10: variable reference (with spaces) 109 | --- expr: { api } 110 | --- err 111 | Invalid variable reference syntax: { api } 112 | --- out 113 | --- status: 255 114 | 115 | 116 | 117 | === TEST 11: set + 118 | --- expr: {api} + {api} 119 | --- err 120 | --- out 121 | api01.foo.com api02.foo.com 122 | --- status: 0 123 | 124 | 125 | 126 | === TEST 12: set - 127 | --- expr: {api} - {api} 128 | --- err 129 | --- out 130 | --- status: 0 131 | 132 | 133 | 134 | === TEST 13: set - 135 | --- expr: {api} - api02* 136 | --- err 137 | --- out 138 | api01.foo.com 139 | --- status: 0 140 | 141 | 142 | 143 | === TEST 14: set - 144 | --- expr: api02* - api01* 145 | --- err 146 | --- out 147 | api02.foo.com 148 | --- status: 0 149 | 150 | 151 | 152 | === TEST 15: set - 153 | --- expr: api02* - {api} 154 | --- err 155 | --- out 156 | --- status: 0 157 | 158 | 159 | 160 | === TEST 16: set * 161 | --- expr: {api} * {api} 162 | --- err 163 | --- out 164 | api01.foo.com api02.foo.com 165 | --- status: 0 166 | 167 | 168 | 169 | === TEST 17: set * (no space) 170 | --- expr: {api}*{api} 171 | --- err 172 | --- out 173 | api01.foo.com api02.foo.com 174 | --- status: 0 175 | 176 | 177 | 178 | === TEST 18: set * 179 | --- expr: {api} * api02* 180 | --- err 181 | --- out 182 | api02.foo.com 183 | --- status: 0 184 | 185 | 186 | 187 | === TEST 19: no spaces around operators 188 | --- expr: api.com-api.com 189 | --- out 190 | api.com-api.com 191 | --- err 192 | --- status: 0 193 | 194 | 195 | 196 | === TEST 20: no spaces around operators 197 | --- expr: api.com+api.com 198 | --- out 199 | api.com+api.com 200 | --- err 201 | --- status: 0 202 | 203 | 204 | 205 | === TEST 21: multiple variable refs 206 | --- rc 207 | # .rc files... 208 | api=api[01-03].foo.com 209 | tq=tq[1101-1105,1011-1021].bar.cn +{api} 210 | --- expr: {api} 211 | --- out 212 | api01.foo.com api02.foo.com api03.foo.com 213 | --- err 214 | --- status: 0 215 | 216 | 217 | 218 | === TEST 22: multiple variable refs 219 | --- rc 220 | # .rc files... 221 | api=api[01-03].foo.com 222 | tq=tq[1101-1105,1011-1021].bar.cn + {api} 223 | --- opts: -x 224 | --- expr: {tq} 225 | --- out 226 | api01.foo.com 227 | api02.foo.com 228 | api03.foo.com 229 | tq1011.bar.cn 230 | tq1012.bar.cn 231 | tq1013.bar.cn 232 | tq1014.bar.cn 233 | tq1015.bar.cn 234 | tq1016.bar.cn 235 | tq1017.bar.cn 236 | tq1018.bar.cn 237 | tq1019.bar.cn 238 | tq1020.bar.cn 239 | tq1021.bar.cn 240 | tq1101.bar.cn 241 | tq1102.bar.cn 242 | tq1103.bar.cn 243 | tq1104.bar.cn 244 | tq1105.bar.cn 245 | --- err 246 | --- status: 0 247 | 248 | 249 | 250 | === TEST 23: intersect 251 | --- expr: {api} * {tq} 252 | --- out 253 | api01.foo.com api02.foo.com api03.foo.com 254 | --- err 255 | --- status: 0 256 | 257 | 258 | 259 | === TEST 24: subtraction 260 | --- expr: {api} - {tq} 261 | --- out 262 | --- err 263 | --- status: 0 264 | 265 | 266 | 267 | === TEST 25: subtraction (reversed) 268 | --- expr: {tq} - {api} 269 | --- opts: -x 270 | --- out 271 | tq1011.bar.cn 272 | tq1012.bar.cn 273 | tq1013.bar.cn 274 | tq1014.bar.cn 275 | tq1015.bar.cn 276 | tq1016.bar.cn 277 | tq1017.bar.cn 278 | tq1018.bar.cn 279 | tq1019.bar.cn 280 | tq1020.bar.cn 281 | tq1021.bar.cn 282 | tq1101.bar.cn 283 | tq1102.bar.cn 284 | tq1103.bar.cn 285 | tq1104.bar.cn 286 | tq1105.bar.cn 287 | --- err 288 | --- status: 0 289 | 290 | 291 | 292 | === TEST 26: ranges with wildcards 293 | --- expr: {tq} * tq[1102-1104]* - tq1103* 294 | --- out 295 | tq1102.bar.cn tq1104.bar.cn 296 | --- err 297 | --- status: 0 298 | 299 | 300 | 301 | === TEST 27: ranges using '..' 302 | --- expr: [a..c].com 303 | --- out 304 | a.com b.com c.com 305 | --- err 306 | --- status: 0 307 | 308 | 309 | 310 | === TEST 28: ranges using - 311 | --- expr: [a-c].com 312 | --- out 313 | a.com b.com c.com 314 | --- err 315 | --- status: 0 316 | 317 | 318 | 319 | === TEST 29: more ranges 320 | --- expr: [aa-ac].com 321 | --- out 322 | aa.com ab.com ac.com 323 | --- err 324 | --- status: 0 325 | 326 | 327 | 328 | === TEST 30: more ranges 329 | --- expr: [9-12].com 330 | --- out 331 | 10.com 11.com 12.com 9.com 332 | --- err 333 | --- status: 0 334 | 335 | 336 | 337 | === TEST 31: more ranges 338 | --- expr: [9-10,11,12,13-14].com 339 | --- out 340 | 10.com 11.com 12.com 13.com 14.com 9.com 341 | --- err 342 | --- status: 0 343 | 344 | 345 | 346 | === TEST 32: two ranges in one pattern 347 | --- expr: [a-b].[1..2].com 348 | --- out 349 | a.1.com a.2.com b.1.com b.2.com 350 | --- err 351 | --- status: 0 352 | 353 | 354 | 355 | === TEST 33: bad range 356 | --- expr: [a-].com 357 | --- err 358 | Bad range: [a-] 359 | --- out 360 | --- status: 255 361 | 362 | 363 | 364 | === TEST 34: bad range (2) 365 | --- expr: [a..].com 366 | --- err 367 | Bad range: [a..] 368 | --- out 369 | --- status: 255 370 | 371 | 372 | 373 | === TEST 35: bad range (3) 374 | --- expr: [].com 375 | --- err 376 | Bad range: [] 377 | --- out 378 | --- status: 255 379 | 380 | 381 | 382 | === TEST 36: not a bad range 383 | --- expr: [a].com 384 | --- err 385 | --- out 386 | a.com 387 | --- status: 0 388 | 389 | 390 | 391 | === TEST 37: bug 392 | --- expr: foo.com *.bar.cn 393 | --- rc 394 | foo=bar 395 | --- out 396 | foo.com 397 | --- err 398 | --- status: 0 399 | 400 | 401 | 402 | === TEST 38: operator precedence 403 | --- expr: {A}-{B}*{C} 404 | --- rc 405 | A=a b c 406 | B=b 407 | C=c 408 | --- out 409 | a b c 410 | --- err 411 | --- status: 0 412 | 413 | 414 | 415 | === TEST 39: set division 416 | --- expr: {A}/{B} 417 | --- rc 418 | A=a b c 419 | B=b c d 420 | --- out 421 | a d 422 | --- err 423 | --- status: 0 424 | 425 | 426 | 427 | === TEST 40: single-line comments in rc 428 | --- expr: {A} + {B} 429 | --- rc 430 | #howdy 431 | A=a c 432 | # blah... 433 | B=b 434 | --- out 435 | a b c 436 | --- err 437 | --- status: 0 438 | 439 | 440 | 441 | === TEST 41: multi-line expressions (two lines) 442 | --- expr: {A} 443 | --- rc 444 | A = a b \ 445 | c 446 | --- out 447 | a b c 448 | --- err 449 | --- status: 0 450 | 451 | 452 | 453 | === TEST 42: multi-line expressions (three lines) 454 | --- expr: {A} 455 | --- rc 456 | A = a b \ 457 | c\ 458 | d 459 | --- out 460 | a b c d 461 | --- err 462 | --- status: 0 463 | 464 | 465 | 466 | === TEST 43: help 467 | --- opts: -h 468 | --- out 469 | USAGE: 470 | 471 | fornodes [OPTIONS] HOST_PATTERN... [OPTIONS] 472 | 473 | OPTIONS: 474 | -h Print this help 475 | -x Expand the host list output to multiple lines. 476 | --- err 477 | --- status: 0 478 | 479 | -------------------------------------------------------------------------------- /t/tonodes.pm: -------------------------------------------------------------------------------- 1 | package t::tonodes; 2 | 3 | use Test::Base -Base; 4 | use IPC::Run3 (); 5 | use FindBin; 6 | 7 | our @EXPORT = qw( run_tests ); 8 | 9 | if (!-d 't/tmp') { 10 | mkdir 't/tmp'; 11 | } 12 | $ENV{LC_ALL} = 'C'; 13 | $ENV{SSH_BATCH_HOME} = "$FindBin::Bin/tmp"; 14 | $ENV{USER} = 'sshbatch'; 15 | #warn $ENV{SSH_BATCH_HOME}; 16 | delete $ENV{SSH_BATCH_LINE_MODE}; 17 | my $RcFile = $ENV{SSH_BATCH_HOME} . '/.fornodesrc'; 18 | 19 | my $is_linux = ($^O =~ /linux/i); 20 | 21 | sub run_tests () { 22 | for my $block (blocks()) { 23 | run_test($block); 24 | } 25 | } 26 | 27 | sub write_rc (@) { 28 | open my $out, ">$RcFile" or 29 | die "Failed to open $RcFile for writing: $!\n"; 30 | print $out @_; 31 | close $out; 32 | } 33 | 34 | sub run_test ($) { 35 | my $block = shift; 36 | my $name = $block->name; 37 | 38 | if (defined $block->linux_only && ! $is_linux) { 39 | diag "$name - Tests skipped on $^O\n"; 40 | for (1..3) { 41 | pass("tests skipped on $^O\n"); 42 | } 43 | return; 44 | } 45 | 46 | my $args = $block->args; 47 | if (!defined $args) { 48 | die "$name - No --- args specified.\n"; 49 | } 50 | chomp $args; 51 | if (!defined $args) { 52 | die "$name - No --- args specified.\n"; 53 | } 54 | if (defined $block->rc) { 55 | write_rc($block->rc); 56 | } elsif (defined $block->no_rc) { 57 | unlink $RcFile; 58 | } 59 | my $prev_home; 60 | if (defined $block->no_home) { 61 | $prev_home = $ENV{SSH_BATCH_HOME}; 62 | $ENV{SSH_BATCH_HOME} = '/foo/bar/baz/32rdssfsd32'; 63 | } 64 | my $cmd = ("\"$^X\" bin/tonodes $args"); 65 | my ($in, $out, $err); 66 | IPC::Run3::run3 $cmd, \$in, \$out, \$err; 67 | if (defined $block->status) { 68 | #warn "status: $?\n"; 69 | if ($block->status == 0) { 70 | is($? >> 8, $block->status, "$name - status ok"); 71 | } else { 72 | ok($? >> 8, "$name - status ok"); 73 | } 74 | } 75 | if (defined $block->no_home) { 76 | $ENV{SSH_BATCH_HOME} = $prev_home; 77 | } 78 | if (defined $block->err) { 79 | $err =~ s/\Q$RcFile\E/**RC_FILE_PATH**/g; 80 | is $err, $block->err, "$name - stderr ok"; 81 | } elsif ($err) { 82 | warn $err, "\n"; 83 | } 84 | if (defined $block->out) { 85 | $out =~ s/\Q$RcFile\E/**RC_FILE_PATH**/g; 86 | is $out, $block->out, "$name - stdout ok"; 87 | } 88 | } 89 | 90 | 1; 91 | 92 | -------------------------------------------------------------------------------- /t/tonodes.t: -------------------------------------------------------------------------------- 1 | # vi:filetype= 2 | 3 | use t::tonodes; 4 | 5 | plan tests => 3 * blocks(); 6 | 7 | #no_diff(); 8 | 9 | run_tests(); 10 | 11 | __DATA__ 12 | 13 | === TEST 1: no home 14 | --- no_home 15 | --- args: t/tonodes.t * :foo 16 | --- err 17 | Can't find the home for the current user. 18 | --- out 19 | --- status: 2 20 | 21 | 22 | 23 | === TEST 2: no rc given 24 | --- args: t/tonodes.t * :foo 25 | --- no_rc 26 | --- out 27 | --- err 28 | Can't open **RC_FILE_PATH** for reading: No such file or directory 29 | --- status: 2 30 | --- SKIP 31 | 32 | 33 | 34 | === TEST 3: no args given 35 | --- rc 36 | api=api01.foo.com api02.foo.com 37 | --- args: 38 | --- out 39 | --- err 40 | No argument specified. 41 | 42 | USAGE: 43 | 44 | tonodes [OPTIONS] FILE... -- HOST_PATTERN... [OPTIONS] 45 | tonodes [OPTIONS] FILE HOST_PATTERN... [OPTIONS] 46 | 47 | OPTIONS: 48 | -c Set SSH concurrency limit. (default: 20) 49 | -b bandwidth limit in Kbits/sec. 50 | -g Use glob to process the input files/directories. 51 | -h Print this help. 52 | -l List the hosts and do nothing else. 53 | -L Use the line-mode output format, i.e., prefixing 54 | every output line with the machine name. 55 | (could be controlled by the env SSH_BATCH_LINE_MODE) 56 | -p Port for the remote SSH service. 57 | -r Recurse into directories too. 58 | -rsync Use "rsync" to transfer files. 59 | -archive Enable rsync archive mode 60 | -update Enable rsync update 61 | -compress Enable rsync compress 62 | -t Specify timeout for net traffic. 63 | -u User account for SSH login. 64 | -v Be verbose. 65 | -w Prompt for password (used mostly for login and sudo, 66 | could be privided by SSH_BATCH_PASSWORD). 67 | -P Prompt for passphrase (used mostly for login, 68 | could be privided by SSH_BATCH_PASSPHRASE). 69 | --- status: 1 70 | 71 | 72 | 73 | === TEST 4: no file 74 | --- args: -- foo.com :/tmp/ 75 | --- out 76 | --- err 77 | No local files/directories specified. 78 | --- status: 255 79 | 80 | 81 | 82 | === TEST 5: no expression 83 | --- args: t/tonodes.t -- :/tmp 84 | --- out 85 | --- err 86 | No cluster expression specified. 87 | --- status: 255 88 | 89 | 90 | 91 | === TEST 6: no target 92 | --- args: t/tonodes.t -- foo.com '*.bar.cn' 93 | --- rc 94 | blah=foo 95 | --- out 96 | --- err 97 | No remote target path specified. 98 | (You forgot to specify ":/path/to/target" at the end of the command line?) 99 | --- status: 1 100 | 101 | 102 | 103 | === TEST 7: multiple servers 104 | --- args: t/tonodes.t -- foo.com '*foo' :~ -l -v 105 | --- rc 106 | blah=foo 107 | --- out 108 | --- err 109 | Using Scp method. 110 | Local files: [t/tonodes.t] 111 | WARNING: Expanding target path ~ to /home/sshbatch 112 | Cluster expression: foo.com *foo 113 | Target path: /home/sshbatch 114 | Cluster set: foo foo.com 115 | --- status: 0 116 | 117 | 118 | 119 | === TEST 8: no dash-dash 120 | --- args: t/tonodes.t foo.com '*foo' :~/ -l -v 121 | --- rc 122 | blah=foo 123 | --- out 124 | --- err 125 | Using Scp method. 126 | Local files: [t/tonodes.t] 127 | WARNING: Expanding target path ~/ to /home/sshbatch/ 128 | Cluster expression: foo.com *foo 129 | Target path: /home/sshbatch/ 130 | Cluster set: foo foo.com 131 | --- status: 0 132 | 133 | 134 | 135 | === TEST 9: local file not found 136 | --- args: t/dfsd2322asdfdt foo.com '*foo' :~ 137 | --- rc 138 | blah=foo 139 | --- out 140 | --- err 141 | Local file/directory t/dfsd2322asdfdt not found. 142 | --- status: 1 143 | 144 | 145 | 146 | === TEST 10: -h 147 | --- args: -h 148 | --- out 149 | USAGE: 150 | 151 | tonodes [OPTIONS] FILE... -- HOST_PATTERN... [OPTIONS] 152 | tonodes [OPTIONS] FILE HOST_PATTERN... [OPTIONS] 153 | 154 | OPTIONS: 155 | -c Set SSH concurrency limit. (default: 20) 156 | -b bandwidth limit in Kbits/sec. 157 | -g Use glob to process the input files/directories. 158 | -h Print this help. 159 | -l List the hosts and do nothing else. 160 | -L Use the line-mode output format, i.e., prefixing 161 | every output line with the machine name. 162 | (could be controlled by the env SSH_BATCH_LINE_MODE) 163 | -p Port for the remote SSH service. 164 | -r Recurse into directories too. 165 | -rsync Use "rsync" to transfer files. 166 | -archive Enable rsync archive mode 167 | -update Enable rsync update 168 | -compress Enable rsync compress 169 | -t Specify timeout for net traffic. 170 | -u User account for SSH login. 171 | -v Be verbose. 172 | -w Prompt for password (used mostly for login and sudo, 173 | could be privided by SSH_BATCH_PASSWORD). 174 | -P Prompt for passphrase (used mostly for login, 175 | could be privided by SSH_BATCH_PASSPHRASE). 176 | --- err 177 | --- status: 0 178 | 179 | 180 | 181 | === TEST 11: option takes a value error 182 | --- args: t foo.com '*foo' :~ -u 183 | --- out 184 | --- err 185 | ERROR: Option -u takes a value. 186 | --- status: 1 187 | 188 | 189 | 190 | === TEST 12: rsync 191 | --- args: t/tonodes.t foo.com:/tmp/ -rsync -l -v 192 | --- err 193 | Using Rsync method. 194 | Local files: [t/tonodes.t] 195 | Cluster expression: foo.com 196 | Target path: /tmp/ 197 | Cluster set: foo.com 198 | --- out 199 | --- status: 0 200 | 201 | 202 | 203 | === TEST 13: skipping directories w/o -r 204 | --- args: t foo.com:~ 205 | --- err 206 | Warning: Skipped directory t. 207 | ERROR: No files to be transferred. 208 | --- out 209 | --- status: 1 210 | 211 | 212 | 213 | === TEST 14: ~foo shortcut 214 | --- args: t/tonodes.t foo.com:~foo -l -v 215 | --- err 216 | Using Scp method. 217 | Local files: [t/tonodes.t] 218 | WARNING: Expanding target path ~foo to /home/foo 219 | Cluster expression: foo.com 220 | Target path: /home/foo 221 | Cluster set: foo.com 222 | --- out 223 | --- status: 0 224 | 225 | 226 | 227 | === TEST 15: ~foo/abc shortcut 228 | --- args: t/tonodes.t foo.com:~foo/abc -l -v 229 | --- err 230 | Using Scp method. 231 | Local files: [t/tonodes.t] 232 | WARNING: Expanding target path ~foo/abc to /home/foo/abc 233 | Cluster expression: foo.com 234 | Target path: /home/foo/abc 235 | Cluster set: foo.com 236 | --- out 237 | --- status: 0 238 | 239 | 240 | 241 | === TEST 16: only leading ~ will be transformed 242 | --- args: t/tonodes.t foo.com:~foo/baz~bar -l -v 243 | --- err 244 | Using Scp method. 245 | Local files: [t/tonodes.t] 246 | WARNING: Expanding target path ~foo/baz~bar to /home/foo/baz~bar 247 | Cluster expression: foo.com 248 | Target path: /home/foo/baz~bar 249 | Cluster set: foo.com 250 | --- out 251 | --- status: 0 252 | 253 | --------------------------------------------------------------------------------