diff --git a/Changes b/Changes index 0cb41bf..08410e4 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,33 @@ +0.030 +- atnodes: added the -W option to atnodes to allow prompting + for passwords for sudo only. thanks JamesPan for the patch. + +0.029 +- atnodes: added a '-q' parameter to run SSH in quiet mode, + which prevents banners and motd messages from being + displayed in the output. thanks Mithun Ayachit for the patch. + +0.028 +- atnodes: fixed tmp file leaks. +- atnodes: automatically check if openssh version >= 4.1. + +0.027 +- added support for the environment SSH_BATCH_RC to specify a + different file name than the default ~/.fornodesrc. + thanks Mithun Ayachit. +- updated host variable format check to /\w[-\.\w]*/. +- added the SSH_BATCH_PASSPHRASE environment for -P and + SSH_BATCH_PASSWORD env for -w. +- added passphrase support. +- added some docs for tty option. + +0.024 +- tonodes: added rsync archive, update and compress mode. (liseen) +- fornodes: trim expressions when parsing them. (liseen) +- atnodes: added the use-tty option. +- fornodes: now we automatically create a default ~/.fornodesrc when it's missing. +- atnodes: added the "StrictHostChecking no" option for the first login. + 0.023 - key2nodes: more examples added to SYNOPSIS in its POD. thanks cnhackTNT++. - added repository address into Makefile.PL, thanks Alexandr Ciornii. diff --git a/MANIFEST b/MANIFEST index 043e722..fe9650e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -37,4 +37,6 @@ Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml -README +README.md +MYMETA.json +MYMETA.yml diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 9bc8e9c..736ba44 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -12,4 +12,4 @@ po/foo\.po$ po/meta\.po$ t/tmp ^\.rsync$ - +^reindex$ diff --git a/META.yml b/META.yml index cf23721..8685a2c 100644 --- a/META.yml +++ b/META.yml @@ -1,14 +1,15 @@ --- abstract: 'Cluster operations based on parallel SSH, set and interval arithmetic' author: - - 'Agent Zhang ' + - 'Zhang "agentzh" Yichun ' build_requires: - ExtUtils::MakeMaker: 6.42 + ExtUtils::MakeMaker: 6.59 IPC::Run3: 0 configure_requires: - ExtUtils::MakeMaker: 6.42 + ExtUtils::MakeMaker: 6.59 distribution_type: module -generated_by: 'Module::Install version 0.91' +dynamic_config: 1 +generated_by: 'Module::Install version 1.14' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -23,11 +24,12 @@ requires: File::Temp: 0 Filter::Util::Call: 0 IO::Pty: 0 - Net::OpenSSH: 0.34 - Set::Scalar: 1.23 - Term::ReadKey: 2.30 + Net::OpenSSH: '0.34' + Set::Scalar: '1.23' + Term::ReadKey: '2.30' + Time::HiRes: 0 perl: 5.6.1 resources: license: http://opensource.org/licenses/bsd-license.php repository: http://github.com/agentzh/sshbatch -version: 0.023 +version: '0.030' diff --git a/MYMETA.yml b/MYMETA.yml new file mode 100644 index 0000000..d60ef2c --- /dev/null +++ b/MYMETA.yml @@ -0,0 +1,31 @@ +--- +abstract: 'Cluster operations based on parallel SSH, set and interval arithmetic' +author: + - 'Zhang "agentzh" Yichun ' +build_requires: + ExtUtils::MakeMaker: '6.59' + IPC::Run3: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' +license: bsd +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: SSH-Batch +no_index: + directory: + - t + - inc +requires: + File::HomeDir: '0' + File::Temp: '0' + Filter::Util::Call: '0' + IO::Pty: '0' + Net::OpenSSH: '0.34' + Set::Scalar: '1.23' + Term::ReadKey: '2.30' + Time::HiRes: '0' + perl: '5.006001' +version: '0.030' diff --git a/Makefile.PL b/Makefile.PL index 34aa759..5316aee 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -4,16 +4,19 @@ use inc::Module::Install; name ('SSH-Batch'); license ('bsd'); -author ('Agent Zhang '); +author ('Zhang "agentzh" Yichun '); perl_version ('5.006001'); all_from ('lib/SSH/Batch.pm'); +repository 'http://github.com/agentzh/sshbatch'; + requires ('Set::Scalar' => '1.23'); requires ('File::HomeDir'); requires ('Net::OpenSSH' => '0.34'); requires ('File::Temp'); requires ('Term::ReadKey' => '2.30'); requires ('IO::Pty'); +requires ('Time::HiRes'); build_requires ('IPC::Run3'); #build_requires ('Test::Base' => '0.54'); @@ -28,6 +31,5 @@ install_script ('bin/tonodes'); install_script ('bin/key2nodes'); auto_install(); -repository 'http://github.com/agentzh/sshbatch'; WriteAll(); diff --git a/README b/README deleted file mode 100644 index fc2fce4..0000000 --- a/README +++ /dev/null @@ -1,411 +0,0 @@ -NAME - SSH::Batch - Cluster operations based on parallel SSH, set and interval - arithmetic - -VERSION - This document describes SSH::Batch 0.023 released on Jan 4, 2010. - -SYNOPSIS - The following scripts are provided: - - fornodes - Expand patterns to machine host list. - - $ cat > ~/.fornodesrc - ps=blah.ps.com bloo.ps.com boo[2-25,32,41-70].ps.com - as=ws[1101-1105].as.com - # use set operations to define new sets: - foo={ps} + {ps} * {as} - {ps} / {as} - bar = foo.com bar.org \ - bah.cn \ - baz.com - ^D - - $ fornodes 'api[02-10].foo.bar.com' 'boo*.ps.com' - $ fornodes 'tq[ab-ac].[1101-1105].foo.com' - $ fornodes '{ps} + {as} - ws1104.as.com' # set union and subtraction - $ fornodes '{ps} * {as}' # set intersect - - atnodes - Run command on clusters. (atnodes calls fornodes internally.) - - # run a command on the specified servers: - $ atnodes $'ps -fe|grep httpd' 'ws[1101-1105].as.com' - - # multiple-arg command requires "--": - $ atnodes ls /opt/ -- '{ps} + {as}' 'localhost' - - # or use single arg command: - $ atnodes 'ls /opt/' '{ps} + {as}' 'localhost' # ditto - - # specify a different user name and SSH server port: - $ atnodes hostname '{ps}' -u agentz -p 12345 - - # use -w to prompt for password if w/o SSH key (no echo back) - $ atnodes hostname '{ps}' -u agentz -w - - # or prompt for password if sudo required... - $ atnodes 'sudo apachectl restart' '{ps}' -w - - # use -P to prompt for passphrase (no echo back) - $ atnodes hostname '{ps}' -u agentz -P - - # run sudo command if tty required... - $ atnodes -tty 'sudo apachectl restart' '{ps}' - - # or specify a timeout: - $ atnodes 'ping foo.com' '{ps}' -t 3 - - tonodes - Upload local files/directories to remote clusters - - $ tonodes /tmp/*.inst -- '{as}:/tmp/' - $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt - - $ tonodes -r /opt /bin/* -- 'ws[1101-1102].foo.com' 'bar.com' :/foo/bar/ - - # use rsync instead of scp: - $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync - - # use rsync archive update compress - $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync -archive -update -compress - - key2nodes - Push the SSH public key (or generate one if not any) to the remote - clusters. - - $ key2nodes 'ws[1101-1105].as.com' - -DESCRIPTION - 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. - - This is a high-level abstraction over the powerful Net::OpenSSH module. - A bunch of handy scripts are provided to simplify big cluster - operations: fornodes, atnodes, tonodes, and key2nodes. - - "SSH::Batch" allows you to name your clusters using variables and - interval/set syntax in your ~/.fornodesrc config file. For instance: - - $ cat ~/.fornodesrc - A=foo[01-03].com bar.org - B=bar.org baz[a-b,d,e-g].cn foo02.com - C={A} * {B} - D={A} - {B} - - 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". - - And then you can query machine host list by using "SSH::Batch"'s - fornodes script: - - $ fornodes '{C}' - bar.org foo02.com - - $ fornodes '{D}' - foo01.com foo03.com - - $ fornodes blah.com '{C} + {D}' - bar.org blah.com foo01.com foo02.com foo03.com - - 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: - - $ fornodes 'foo-bar-[a-d].com - foo-bar-c.com' - foo-bar-a.com foo-bar-b.com foo-bar-d.com - - for the ranges like "[a-z]", there's also an alternative syntax: - - [a..z] - - To exclude some discrete values from certain range, you need set - subtration: - - foo[1-100].com - foo[32,56].com - - or equivalently - - foo[1-31,33-55,57-100].com - - fornodes could be very handy in shell programming. For example, to test - the 80 port HTTP service of a cluster "A", simply put - - $ for node in `fornodes '{A}'`; \ - do curl "http://$node:80/blah'; \ - done - - Also, other scripts in this module, like atnodes, tonodes, and key2nodes - also call fornodes internally so that you can use the cluster spec - syntax in those scripts' command line as well. - - atnodes meets the common requirement of running a command on a remote - cluster. For example: - - # at the concurrency level of 6: - atnodes 'ls -lh' '{A} + {B}' my.more.com -c 6 - - Or upload a local file to the remote cluster: - - tonodes ~/my.tar.gz '{A} / {B}' :/tmp/ - - or multiple files as well as some directories: - - tonodes -r ~/mydir ~/mydir2/*.so -- foo.com bar.cn :~/ - - It's also possible to use wildcards in the cluster spec expression, as - in - - atnodes 'ls ~' 'api??.*.com' - - where 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. - - There's also a key2nodes script to push SSH public keys to remote - machines ;) - -TIPS - There's some extra tips found in our own's everyday use: - - Running sudo commands - Often, we want to run commands requiring root access, such as when - installing software packages on remote machines. So you'll have to - tell atnodes to prompt for your password: - - $ atnodes 'sudo yum install blah' '{my_cluster}' -w - - Then you'll be prompted by the "Password:" prompt after which you - enter your remote password (with echo back turned off). - - Because the remote sshd might be smart enough to "remember" the sudo - password for a (small) amount of time, immediate subsequent "sudo" - might omit the "-w" option, as in - - $ atnodes 'sudo mv ~/foo /usr/local/bin/' {my_cluster} - - But remember, you can use *sudo without passwords* just for a - *small* amount of time ;) - - If you see the following error message while doing sudo with atnodes - - sudo: sorry, you must have a tty to run sudo - - 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). - - Passing custom options to the underlying "ssh" - By default, "atnodes" relies on 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 script also - supports the "SSH_BATCH_SSH_CMD" environment.) - - Note that to specify your own "ssh" is also a way to pass more - options to the underlying OpenSSH client executable when using - "atnodes": - - $ cat > ~/bin/myssh - #!/bin/sh - # to enable X11 forwarding: - exec ssh -X "$@" - ^D - - $ chmod +x ~/bin/myssh - - $ export SSH_BATCH_SSH_CMD=~/bin/myssh - $ atnodes 'ls -lh' '{my_cluster_name}' - - It's important to use "exec" in your own ssh wrapper script, or you - may see "atnodes" hangs. - - This trick also works for the key2nodes script. - - Use wildcard for cluster expressions to save typing - Wildcards in cluster spec could save a lot of typing. Say, if you - have "api10.foo.bar.baz.bah.com.cn" appeared in your ~/.fornodesrc - file: - - $ cat ~/.fornodesrc - MyCluster=api[01-22].foo.bar.baz.bah.com.cn - - 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. - - But use wildcards with care. You may have nodes that you don't want - in your resulting host list. So it's best practice to use -l option - when you use wildcards with atnodes or tonodes, as in - - $ atnodes 'rm -rf /opt/blah' 'api10*' -l - - So that atnodes will just echos out the exact host list that it - would operate on but without doing anything. (It's effectively a - "dry-run".) After checking, you can safely remove the "-l" option - and go on. - - Specify a different ssh port or user name. - 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 - - $ cat > ~/.fornodesrc - # cluster A uses the default user name: - A=foo[01-25].com - # cluster B uses the non-default user name "jim" and a port 12345 - B=jim@foo[26-28].com:12345 - - $ atnodes 'ls -lh' '{B} + bob@bar[29-31].org:5678' - - Use "-L" to help grepping the outputs by hostname - When managing hundreds or even thousands of machines, it's often - more convenient to "grep" over the outputs of atnodes or tonodes by - host names. The "-L" option makes atnodes and tonodes to prefixing - every output lines of the remote commands (if any) by the host name. - As in - - $ atnodes 'top -b|head -n5' '{my_big_cluster}' -L > out.txt 2>&1 - $ grep 'some.specific.host.com' out.txt - - Specify a timeout to prevent hanging - It's often wise to specify a timeout for SSH operations. For - example, if there's 3 sec of network traffic silence, the following - command will quit with an error message printed: - - $ atnodes -t 3 'sleep 4' {my_cluster} - - Limit the bandwith used by tonodes to be firewall-friendly - You can use the "-b" option to tell tonodes to use limited bandwidth - if your intranet's Firewall is paranoid about your bandwidth use: - - $ tonodes my_big_file {my_cluster}:/tmp/ -b 8000 - - where 8000 is in the unit of Kbits/sec, so it will not transfer - faster than 1 MByte/sec. - - Avoid logging manually for the first time - When you use key2nodes or atnodes to access remote servers that you - have never logged in manually, you would probably see the following - errors: - - ===================== foo.com ===================== - Failed to spawn command. - - ERROR: unable to establish master SSH connection: the authenticity of the target host can't be established, try loging manually first - - A work-around is using "ssh" to login to that "foo.com" machine - manually and then try key2nodes or atnodes again. - - Another nicer work-around is to pass the "-o - 'StrictHostKeyChecking=no'" option to the underlying ssh executable - used by "SSH::Batch". Here's a quick HOW-TO: - - $ cat > ~/bin/myssh - #!/bin/sh - # to disable StrictHostKeyChecking - exec ssh -o 'StrictHostKeyChecking=no' "$@" - ^D - - $ chmod +x ~/bin/myssh - - $ export SSH_BATCH_SSH_CMD=~/bin/myssh - - # then we try again - $ key2nodes foo.com - $ atnodes 'hostname' foo.com - -PREREQUISITES - This module uses 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: - - $ ssh -v - - On my machine, it echos - - OpenSSH_4.7p1 Debian-8ubuntu1.2, OpenSSL 0.9.8g 19 Oct 2007 - usage: ssh [-1246AaCfgKkMNnqsTtVvXxY] [-b bind_address] [-c cipher_spec] - [-D [bind_address:]port] [-e escape_char] [-F configfile] - [-i identity_file] [-L [bind_address:]port:host:hostport] - [-l login_name] [-m mac_spec] [-O ctl_cmd] [-o option] [-p port] [-R [bind_address:]port:host:hostport] [-S ctl_path] - [-w local_tun[:remote_tun]] [user@]hostname [command] - - There's no spesial requirement on the server side ssh service. Even a - non-OpenSSH server-side deamon should work as well. - -INSTALLATION - perl Makefile.PL - make - make test - sudo make install - - Win32 users should replace "make" with "nmake". - -SOURCE CONTROL - You can always get the latest SSH::Batch source from its public Git - repository: - - http://github.com/agentzh/sshbatch/tree/master - - If you have a branch for me to pull, please let me know ;) - -TODO - * Cache the parsing and evaluation results of the config file - ~/.fornodesrc to somewhere like the fiel ~/.fornodesrc.cached. - - * Abstract the duplicate code found in the scripts to a shared .pm - file. - - * Add the fromnodes script to help downloading files from the remote - clusters to local file system (maybe grouped by host name). - - * Add the betweennodes script to transfer files between clusters - through localhost. - -SEE ALSO - fornodes, atnodes, tonodes, key2nodes, SSH::Batch::ForNodes, - Net::OpenSSH. - -COPYRIGHT AND LICENSE - This module as well as its programs are licensed under the BSD License. - - Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights - reserved. - - Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * 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. - - * 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. - - 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. - diff --git a/README.md b/README.md new file mode 100644 index 0000000..1e432ce --- /dev/null +++ b/README.md @@ -0,0 +1,402 @@ +# NAME + +SSH::Batch - Cluster operations based on parallel SSH, set and interval arithmetic + +Table of Contents +================= + +* [NAME](#name) +* [VERSION](#version) +* [SYNOPSIS](#synopsis) +* [DESCRIPTION](#description) +* [TIPS](#tips) +* [PREREQUISITES](#prerequisites) +* [INSTALLATION](#installation) +* [CODE REPOSITORY](#code-repository) +* [TODO](#todo) +* [AUTHORS](#authors) +* [COPYRIGHT & LICENSE](#copyright--license) +* [SEE ALSO](#see-also) + +# VERSION + +This document describes SSH::Batch 0.030 released on 8 November 2015. + +# SYNOPSIS + +The following scripts are provided: + +- fornodes + + Expand patterns to machine host list. + + $ cat > ~/.fornodesrc + ps=blah.ps.com bloo.ps.com boo[2-25,32,41-70].ps.com + as=ws[1101-1105].as.com + # use set operations to define new sets: + foo={ps} + {ps} * {as} - {ps} / {as} + bar = foo.com bar.org \ + bah.cn \ + baz.com + ^D + + $ fornodes 'api[02-10].foo.bar.com' 'boo*.ps.com' + $ fornodes 'tq[ab-ac].[1101-1105].foo.com' + $ fornodes '{ps} + {as} - ws1104.as.com' # set union and subtraction + $ fornodes '{ps} * {as}' # set intersect + +- atnodes + + Run command on clusters. (atnodes calls fornodes internally.) + + # run a command on the specified servers: + $ atnodes $'ps -fe|grep httpd' 'ws[1101-1105].as.com' + + # multiple-arg command requires "--": + $ atnodes ls /opt/ -- '{ps} + {as}' 'localhost' + + # or use single arg command: + $ atnodes 'ls /opt/' '{ps} + {as}' 'localhost' # ditto + + # specify a different user name and SSH server port: + $ atnodes hostname '{ps}' -u agentz -p 12345 + + # use -w to prompt for password if w/o SSH key (no echo back) + $ atnodes hostname '{ps}' -u agentz -w + + # or prompt for password if both login and sudo are required... + $ atnodes 'sudo apachectl restart' '{ps}' -w + + # or prompt for password for sudo only... + $ atnodes 'sudo apachectl restart' '{ps}' -W + + # run sudo command if tty required... + $ atnodes -tty 'sudo apachectl restart' '{ps}' + + # or specify a timeout: + $ atnodes 'ping foo.com' '{ps}' -t 3 + +- tonodes + + Upload local files/directories to remote clusters + + $ tonodes /tmp/*.inst -- '{as}:/tmp/' + $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt + + # use rsync instead of scp: + $ tonodes foo.txt 'ws1105*' :/tmp/bar.txt -rsync + + $ tonodes -r /opt /bin/* -- 'ws[1101-1102].foo.com' 'bar.com' :/foo/bar/ + +- key2nodes + + Push the SSH public key (or generate one if not any) to the remote clusters. + + $ key2nodes 'ws[1101-1105].as.com' + +# DESCRIPTION + +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. + +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). + +`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: + + $ cat ~/.fornodesrc + A=foo[01-03].com bar.org + B=bar.org baz[a-b,d,e-g].cn foo02.com + C={A} * {B} + D={A} - {B} + +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`. + +And then you can query machine host list by using `SSH::Batch`'s [fornodes](https://metacpan.org/pod/fornodes) script: + + $ fornodes '{C}' + bar.org foo02.com + + $ fornodes '{D}' + foo01.com foo03.com + + $ fornodes blah.com '{C} + {D}' + bar.org blah.com foo01.com foo02.com foo03.com + +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: + + $ fornodes 'foo-bar-[a-d].com - foo-bar-c.com' + foo-bar-a.com foo-bar-b.com foo-bar-d.com + +for the ranges like `[a-z]`, there's also an alternative syntax: + + [a..z] + +To exclude some discrete values from certain range, you need set subtration: + + foo[1-100].com - foo[32,56].com + +or equivalently + + foo[1-31,33-55,57-100].com + +[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 + + $ for node in `fornodes '{A}'`; \ + do curl "http://$node:80/blah'; \ + done + +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. + +[atnodes](https://metacpan.org/pod/atnodes) meets the common requirement of running a command on a remote cluster. For example: + + # at the concurrency level of 6: + atnodes 'ls -lh' '{A} + {B}' my.more.com -c 6 + +Or upload a local file to the remote cluster: + + tonodes ~/my.tar.gz '{A} / {B}' :/tmp/ + +or multiple files as well as some directories: + + tonodes -r ~/mydir ~/mydir2/*.so -- foo.com bar.cn :~/ + +It's also possible to use wildcards in the cluster spec expression, as in + + atnodes 'ls ~' 'api??.*.com' + +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. + +There's also a [key2nodes](https://metacpan.org/pod/key2nodes) script to push SSH public keys to remote machines ;) + +[Back to TOC](#table-of-contents) + +# TIPS + +There's some extra tips found in our own's everyday use: + +- Running sudo commands + + Often, we want to run commands requiring root access, such as when installing + software packages on remote machines. So you'll have to tell [atnodes](https://metacpan.org/pod/atnodes) to + prompt for your password: + + $ atnodes 'sudo yum install blah' '{my_cluster}' -w + + Then you'll be prompted by the `Password:` prompt after which you enter your + remote password (with echo back turned off). + + Because the remote `sshd` might be smart enough to "remember" the sudo password + for a (small) amount of time, immediate subsequent "sudo" might omit the `-w` option, as in + + $ atnodes 'sudo mv ~/foo /usr/local/bin/' {my_cluster} + + But remember, you can use _sudo without passwords_ just for a _small_ amount of + time ;) + + If you see the following error message while doing sudo with [atnodes](https://metacpan.org/pod/atnodes) + + sudo: sorry, you must have a tty to run sudo + + 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). + +- Passing custom options to the underlying `ssh` + + 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.) + + Note that to specify your own "ssh" is also a way to pass more options to the underlying OpenSSH client executable when using `atnodes`: + + $ cat > ~/bin/myssh + #!/bin/sh + # to enable X11 forwarding: + exec ssh -X "$@" + ^D + + $ chmod +x ~/bin/myssh + + $ export SSH_BATCH_SSH_CMD=~/bin/myssh + $ atnodes 'ls -lh' '{my_cluster_name}' + + It's important to use "exec" in your own ssh wrapper script, or you may see `atnodes` hangs. + + This trick also works for the [key2nodes](https://metacpan.org/pod/key2nodes) script. + +- Use wildcard for cluster expressions to save typing + + Wildcards in cluster spec could save a lot of typing. Say, if you have + `api10.foo.bar.baz.bah.com.cn` appeared in your `~/.fornodesrc` file: + + $ cat ~/.fornodesrc + MyCluster=api[01-22].foo.bar.baz.bah.com.cn + + 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. + + But use wildcards with care. You may have nodes that you don't want in your + resulting host list. So it's best practice to use [-l](https://metacpan.org/pod/-l) option when you use + wildcards with [atnodes](https://metacpan.org/pod/atnodes) or [tonodes](https://metacpan.org/pod/tonodes), as in + + $ atnodes 'rm -rf /opt/blah' 'api10*' -l + + So that [atnodes](https://metacpan.org/pod/atnodes) will just echos out the exact host list that it would + operate on but without doing anything. (It's effectively a "dry-run".) + After checking, you can safely remove the `-l` option and go on. + +- Specify a different ssh port or user name. + + 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 + + $ cat > ~/.fornodesrc + # cluster A uses the default user name: + A=foo[01-25].com + # cluster B uses the non-default user name "jim" and a port 12345 + B=jim@foo[26-28].com:12345 + + $ atnodes 'ls -lh' '{B} + bob@bar[29-31].org:5678' + + It's also possible to specify a different rc config file than `~/.fornodesrc` via the environment variable `SSH_BATCH_RC`. For example, + + export SSH_BATCH_RC=/opt/my-fornodes-rc + + then the file `/opt/my-fornodes-rc` will be used instead of the default `~/.fornodesrc` file. + +- Use `-L` to help grepping the outputs by hostname + + When managing hundreds or even thousands of machines, it's often more + convenient to `grep` over the outputs of [atnodes](https://metacpan.org/pod/atnodes) or [tonodes](https://metacpan.org/pod/tonodes) by + host names. The `-L` option makes [atnodes](https://metacpan.org/pod/atnodes) and [tonodes](https://metacpan.org/pod/tonodes) to prefixing + every output lines of the remote commands (if any) by the host name. As in + + $ atnodes 'top -b|head -n5' '{my_big_cluster}' -L > out.txt 2>&1 + $ grep 'some.specific.host.com' out.txt + +- Specify a timeout to prevent hanging + + It's often wise to specify a timeout for SSH operations. For example, + if there's 3 sec of network traffic silence, the following command will + quit with an error message printed: + + $ atnodes -t 3 'sleep 4' {my_cluster} + +- Limit the bandwith used by [tonodes](https://metacpan.org/pod/tonodes) to be firewall-friendly + + You can use the `-b` option to tell [tonodes](https://metacpan.org/pod/tonodes) to use limited bandwidth + if your intranet's Firewall is paranoid about your bandwidth use: + + $ tonodes my_big_file {my_cluster}:/tmp/ -b 8000 + + where `8000` is in the unit of Kbits/sec, so it will not transfer + faster than 1 MByte/sec. + +- Avoid logging manually for the first time + + When you use [key2nodes](https://metacpan.org/pod/key2nodes) or [atnodes](https://metacpan.org/pod/atnodes) to access remote servers + that you have never logged in manually, you would probably see the + following errors: + + ===================== foo.com ===================== + Failed to spawn command. + + ERROR: unable to establish master SSH connection: the authenticity of the target host can't be established, try loging manually first + + A work-around is using "ssh" to login to that `foo.com` machine + manually and then try [key2nodes](https://metacpan.org/pod/key2nodes) or [atnodes](https://metacpan.org/pod/atnodes) again. + + Another nicer work-around is to pass the `-o 'StrictHostKeyChecking=no'` option to the underlying `ssh` executable used by `SSH::Batch`. + Here's a quick HOW-TO: + + $ cat > ~/bin/myssh + #!/bin/sh + # to disable StrictHostKeyChecking + exec ssh -o 'StrictHostKeyChecking=no' "$@" + ^D + + $ chmod +x ~/bin/myssh + + $ export SSH_BATCH_SSH_CMD=~/bin/myssh + + # then we try again + $ key2nodes foo.com + $ atnodes 'hostname' foo.com + +[Back to TOC](#table-of-contents) + +# PREREQUISITES + +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: + + $ ssh -v + +On my machine, it echos + + OpenSSH_4.7p1 Debian-8ubuntu1.2, OpenSSL 0.9.8g 19 Oct 2007 + usage: ssh [-1246AaCfgKkMNnqsTtVvXxY] [-b bind_address] [-c cipher_spec] + [-D [bind_address:]port] [-e escape_char] [-F configfile] + [-i identity_file] [-L [bind_address:]port:host:hostport] + [-l login_name] [-m mac_spec] [-O ctl_cmd] [-o option] [-p port] [-R [bind_address:]port:host:hostport] [-S ctl_path] + [-w local_tun[:remote_tun]] [user@]hostname [command] + +There's no spesial requirement on the server side ssh service. Even a non-OpenSSH server-side deamon should work as well. + +[Back to TOC](#table-of-contents) + +# INSTALLATION + + perl Makefile.PL + make + make test + sudo make install + +Win32 users should replace "make" with "nmake". + +[Back to TOC](#table-of-contents) + +# CODE REPOSITORY + +You can always get the latest `SSH::Batch` source from its public Git repository: + +[http://github.com/agentzh/sshbatch](http://github.com/agentzh/sshbatch) + +If you have a branch for me to pull, please let me know ;) + +[Back to TOC](#table-of-contents) + +# TODO + +- Cache the parsing and evaluation results of the config file `~/.fornodesrc` +to somewhere like the fiel `~/.fornodesrc.cached`. +- Abstract the duplicate code found in the scripts to a shared .pm file. +- Add the `fromnodes` script to help downloading files from the remote +clusters to local file system (maybe grouped by host name). +- Add the `betweennodes` script to transfer files between clusters through +localhost. + +[Back to TOC](#table-of-contents) + +# AUTHORS + +- Zhang "agentzh" Yichun (章亦春) `` +- Liseen Wan (万珣新) `` + +[Back to TOC](#table-of-contents) + +# COPYRIGHT & LICENSE + +This module as well as its programs are licensed under the BSD License. + +Copyright (C) 2009-2015, Yichun "agentzh" Zhang (章亦春). All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. +- 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. +- 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. + +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. + +[Back to TOC](#table-of-contents) + +# SEE ALSO + +[fornodes](https://metacpan.org/pod/fornodes), [atnodes](https://metacpan.org/pod/atnodes), [tonodes](https://metacpan.org/pod/tonodes), [key2nodes](https://metacpan.org/pod/key2nodes), +[SSH::Batch::ForNodes](https://metacpan.org/pod/SSH::Batch::ForNodes), [Net::OpenSSH](https://metacpan.org/pod/Net::OpenSSH). + +[Back to TOC](#table-of-contents) + diff --git a/bin/atnodes b/bin/atnodes old mode 100644 new mode 100755 index cffc7a2..5deeaa3 --- a/bin/atnodes +++ b/bin/atnodes @@ -12,6 +12,7 @@ use File::Temp qw/ :POSIX /; use Time::HiRes qw/sleep/; sub help ($); +sub check_openssh_version ($); if (!@ARGV) { warn "No argument specified.\n\n"; @@ -19,7 +20,8 @@ if (!@ARGV) { } my $list_hosts_only = 0; -my ($user, $port, $timeout, $verbose, $ask_for_pass, $ask_for_passphrase); +my ($user, $port, $timeout, $verbose, $ask_for_pass); +my ($ask_for_pass_only_for_sudo, $ask_for_passphrase); my $concurrency = 20; my (@cmd, @exprs, $ssh_cmd); $ssh_cmd = $ENV{SSH_BATCH_SSH_CMD}; @@ -28,6 +30,7 @@ my $fetch_value; my $found_sep; my $last_option; my $use_tty; +my $use_quiet_mode; my $line_mode = $ENV{SSH_BATCH_LINE_MODE}; for (@ARGV) { if (defined $fetch_value) { @@ -57,6 +60,8 @@ for (@ARGV) { $verbose = 1; } elsif ($group eq 'w') { $ask_for_pass = 1; + } elsif ($group eq 'W') { + $ask_for_pass_only_for_sudo = 1; } elsif ($group eq 'P') { $ask_for_passphrase = 1; } elsif ($group eq 'c') { @@ -67,6 +72,8 @@ for (@ARGV) { $line_mode = 1; } elsif ($group eq 'tty') { $use_tty = 1; + } elsif ($group eq 'q') { + $use_quiet_mode = 1; } else { die "Unknown option: $_\n"; } @@ -75,6 +82,12 @@ for (@ARGV) { } push @exprs, $_; } + +if ($ask_for_pass && $ask_for_pass_only_for_sudo) { + die "ERROR: Option -w should not be used together with -W.\n", + "Use -w to use passowrd for login and sudo, -W for sudo only.\n"; +} + if (defined $fetch_value) { die "ERROR: Option $last_option takes a value.\n"; } @@ -93,6 +106,8 @@ if ($verbose) { } } +check_openssh_version($ssh_cmd || 'ssh'); + if ($use_tty) { $concurrency = 1; } @@ -139,7 +154,7 @@ if ($ask_for_passphrase) { if (!$passphrase) { die "No passphrase specified.\n"; } -} elsif ($ask_for_pass) { +} elsif ($ask_for_pass || $ask_for_pass_only_for_sudo) { $password = $ENV{SSH_BATCH_PASSWORD}; if (!$password) { print STDERR "Password:"; @@ -164,6 +179,7 @@ while (1) { while ($active_count < $concurrency) { last if !@hosts; my $host = shift @hosts; + my $login_with_password = (defined $password) && !$ask_for_pass_only_for_sudo; my $ssh = Net::OpenSSH->new( $host, async => 1, @@ -171,8 +187,11 @@ while (1) { defined $user ? (user => $user) : (), defined $port ? (port => $port) : (), defined $passphrase ? (passphrase => $passphrase) : (), - defined $password ? (password => $password) : (), + $login_with_password ? (password => $password) : (), defined $ssh_cmd ? (ssh_cmd => $ssh_cmd) : (), + $use_quiet_mode + ? (master_opts => ["-q",], default_ssh_opts => ["-q",],) + : (), ); if ($ssh->error) { if ($line_mode) { @@ -269,6 +288,7 @@ while (1) { print "\n"; } close $in; + unlink $outfile; } } @@ -296,11 +316,14 @@ OPTIONS: -t Specify timeout for net traffic. -u User account for SSH login. -v Be verbose. - -w Prompt for password (used for login and sudo, + -w Prompt for password (used for both login and sudo, could be privided by SSH_BATCH_PASSWORD). + -W Prompt for password (just for sudo), + should not be used with -w. -P Prompt for passphrase (used for login, could be privided by SSH_BATCH_PASSPHRASE). -tty Pseudo-tty. + -q Run SSH in quiet mode _EOC_ if ($exit_code == 0) { print $msg; @@ -310,8 +333,23 @@ _EOC_ exit($exit_code); } } + +sub check_openssh_version ($) { + my $ssh_cmd = shift; + + my $version_info = `$ssh_cmd -V 2>&1`; + if ($version_info && $version_info =~ /^OpenSSH_(\d+\.\d+)/) { + my $v = $1; + if ($v && $v < 4.1) { + die "OpenSSH version $v, should be >= 4.1!\n"; + } + } +} + __END__ +=encoding utf-8 + =head1 NAME atnodes - Run commands on clusters @@ -333,9 +371,12 @@ atnodes - Run commands on clusters # use -w to prompt for password if w/o SSH key (no echo back) $ atnodes hostname '{ps}' -u agentz -w - # or prompt for password if sudo required... + # or prompt for password if login and sudo required... $ atnodes 'sudo apachectl restart' '{ps}' -w + # or prompt for password for sudo only... + $ atnodes 'sudo apachectl restart' '{ps}' -W + # use -P to prompt for passphrase (no echo back) $ atnodes hostname '{ps}' -u agentz -P @@ -367,9 +408,12 @@ atnodes - Run commands on clusters -v Be verbose. -w Prompt for password (used for login and sudo, could be privided by SSH_BATCH_PASSWORD). + -W Prompt for password (like -w but conflict, just for sudo. + Never use -W together with -w, because -w will be ignored). -P Prompt for passphrase (used for login, could be privided by SSH_BATCH_PASSPHRASE). -tty Pseudo-tty. + -q Run SSH in quiet mode =head1 PREREQUISITES @@ -396,13 +440,27 @@ Please refer to L for more documentation. L, L, L, L, L. -=head1 COPYRIGHT AND LICENSE +=head1 AUTHORS + +=over + +=item * + +Zhang "agentzh" Yichun (章亦春) C<< >> + +=item * + +Liseen Wan (万珣新) C<< >> + +=back + +=head1 COPYRIGHT & LICENSE This module as well as its programs are licensed under the BSD License. Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. -Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. +Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun (章亦春). All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/bin/fornodes b/bin/fornodes old mode 100644 new mode 100755 index 17c4007..7a3293b --- a/bin/fornodes +++ b/bin/fornodes @@ -67,6 +67,8 @@ _EOC_ __END__ +=encoding utf-8 + =head1 NAME fornodes - Expand patterns to machine host list @@ -101,17 +103,27 @@ fornodes - Expand patterns to machine host list Please refer to L for more documentation. -=head1 SEE ALSO +=head1 AUTHORS -L, L, L, L, L. +=over + +=item * + +Zhang "agentzh" Yichun (章亦春) C<< >> + +=item * + +Liseen Wan (万珣新) C<< >> + +=back -=head1 COPYRIGHT AND LICENSE +=head1 COPYRIGHT & LICENSE This module as well as its programs are licensed under the BSD License. -Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. +Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. -Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. +Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun (章亦春). Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -133,3 +145,7 @@ Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of i 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. +=head1 SEE ALSO + +L, L, L, L, L. + diff --git a/bin/key2nodes b/bin/key2nodes old mode 100644 new mode 100755 index 44688f8..0e6085a --- a/bin/key2nodes +++ b/bin/key2nodes @@ -253,6 +253,8 @@ _EOC_ } __END__ +=encoding utf-8 + =head1 NAME key2nodes - Push SSH public keys to remote clusters @@ -305,7 +307,7 @@ This module as well as its programs are licensed under the BSD License. Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. -Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. +Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun (章亦春). All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/bin/tonodes b/bin/tonodes old mode 100644 new mode 100755 index 94ff252..1b1a42c --- a/bin/tonodes +++ b/bin/tonodes @@ -375,6 +375,8 @@ _EOC_ } __END__ +=encoding utf-8 + =head1 NAME tonodes - Upload local files/directories to remote clusters @@ -428,17 +430,27 @@ tonodes - Upload local files/directories to remote clusters Please refer to L for more documentation. -=head1 SEE ALSO +=head1 AUTHORS -L, L, L, L, L. +=over + +=item * + +Zhang "agentzh" Yichun (章亦春) C<< >> + +=item * + +Liseen Wan (万珣新) C<< >> + +=back -=head1 COPYRIGHT AND LICENSE +=head1 COPYRIGHT & LICENSE This module as well as its programs are licensed under the BSD License. Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. -Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. +Copyright (C) 2009, 2010, 2011, Zhang "agentzh" Yichun. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -460,3 +472,7 @@ Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of i 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. +=head1 SEE ALSO + +L, L, L, L, L. + diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm index dfb8ef7..cd93d14 100644 --- a/inc/Module/AutoInstall.pm +++ b/inc/Module/AutoInstall.pm @@ -3,11 +3,12 @@ package Module::AutoInstall; use strict; use Cwd (); +use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { - $VERSION = '1.03'; + $VERSION = '1.14'; } # special map on pre-defined feature sets @@ -17,11 +18,14 @@ my %FeatureMap = ( ); # various lexical flags -my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); +my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( - $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps + $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, + $UpgradeDeps ); -my ( $PostambleActions, $PostambleUsed ); +my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, + $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, + $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); @@ -31,6 +35,10 @@ sub _accept_default { $AcceptDefault = shift; } +sub _installdeps_target { + $InstallDepsTarget = shift; +} + sub missing_modules { return @Missing; } @@ -63,6 +71,11 @@ sub _init { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } + elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { + $UpgradeDeps = 1; + __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); + exit 0; + } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } @@ -102,7 +115,7 @@ sub import { print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; - my $cwd = Cwd::cwd(); + my $cwd = Cwd::getcwd(); $Config = []; @@ -125,7 +138,7 @@ sub import { # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message - $UnderCPAN = _check_lock(1) unless $SkipInstall; + $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); @@ -153,7 +166,7 @@ sub import { $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } - if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability + if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { @@ -175,7 +188,7 @@ sub import { } # XXX: check for conflicts and uninstalls(!) them. - my $cur = _load($mod); + my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; @@ -207,6 +220,7 @@ sub import { $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps + or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) @@ -237,10 +251,17 @@ sub import { } } - if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { + if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; - print -"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; + my $make = $Config::Config{make}; + if ($InstallDepsTarget) { + print +"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; + } + else { + print +"*** Dependencies will be installed the next time you type '$make'.\n"; + } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" @@ -253,6 +274,8 @@ sub import { # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; + + return (@Existing, @Missing); } sub _running_under { @@ -269,6 +292,10 @@ END_MESSAGE sub _check_lock { return unless @Missing or @_; + if ($ENV{PERL5_CPANM_IS_RUNNING}) { + return _running_under('cpanminus'); + } + my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { @@ -318,17 +345,26 @@ sub install { my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); - my ( @modules, @installed ); - while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { + my ( @modules, @installed, @modules_to_upgrade ); + while (my ($pkg, $ver) = splice(@_, 0, 2)) { - # grep out those already installed - if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { - push @installed, $pkg; - } - else { - push @modules, $pkg, $ver; - } - } + # grep out those already installed + if (_version_cmp(_version_of($pkg), $ver) >= 0) { + push @installed, $pkg; + if ($UpgradeDeps) { + push @modules_to_upgrade, $pkg, $ver; + } + } + else { + push @modules, $pkg, $ver; + } + } + + if ($UpgradeDeps) { + push @modules, @modules_to_upgrade; + @installed = (); + @modules_to_upgrade = (); + } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell @@ -361,7 +397,7 @@ sub install { # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { - if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { + if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { @@ -461,6 +497,11 @@ sub _cpanplus_config { } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } + push @config, 'prereqs', $value; + } elsif ( $key eq 'force' ) { + push @config, $key, $value; + } elsif ( $key eq 'notest' ) { + push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } @@ -495,10 +536,14 @@ sub _install_cpan { # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) - if $opt =~ /^force$/; # pseudo-option + if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } + if ($args{notest} && (not CPAN::Shell->can('notest'))) { + die "Your version of CPAN is too old to support the 'notest' pragma"; + } + local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { @@ -517,8 +562,16 @@ sub _install_cpan { delete $INC{$inc}; } - my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) - : CPAN::Shell->install($pkg); + my $rv = do { + if ($args{force}) { + CPAN::Shell->force( install => $pkg ) + } elsif ($args{notest}) { + CPAN::Shell->notest( install => $pkg ) + } else { + CPAN::Shell->install($pkg) + } + }; + $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} @@ -562,7 +615,7 @@ sub _under_cpan { require Cwd; require File::Spec; - my $cwd = File::Spec->canonpath( Cwd::cwd() ); + my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); @@ -573,7 +626,7 @@ sub _update_to { my $ver = shift; return - if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade + if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", @@ -658,21 +711,48 @@ sub _can_write { # load a module and return the version it reports sub _load { - my $mod = pop; # class/instance doesn't matter + my $mod = pop; # method/function doesn't matter my $file = $mod; - $file =~ s|::|/|g; $file .= '.pm'; - local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } +# report version without loading a module +sub _version_of { + my $mod = pop; # method/function doesn't matter + my $file = $mod; + $file =~ s|::|/|g; + $file .= '.pm'; + foreach my $dir ( @INC ) { + next if ref $dir; + my $path = File::Spec->catfile($dir, $file); + next unless -e $path; + require ExtUtils::MM_Unix; + return ExtUtils::MM_Unix->parse_version($path); + } + return undef; +} + # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; - if ( $CPAN::HandleConfig::VERSION ) { + + # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to + # CPAN::HandleConfig->load. CPAN reports that the redirection + # is deprecated in a warning printed at the user. + + # CPAN-1.81 expects CPAN::HandleConfig->load, does not have + # $CPAN::HandleConfig::VERSION but cannot handle + # CPAN::Config->load + + # Which "versions expect CPAN::Config->load? + + if ( $CPAN::HandleConfig::VERSION + || CPAN::HandleConfig->can('load') + ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { @@ -748,6 +828,35 @@ sub _make_args { : "\$(NOECHO) \$(NOOP)" ); + my $deps_list = join( ',', @Missing, @Existing ); + + $PostambleActionsUpgradeDeps = + "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; + + my $config_notest = + join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), + 'notest', 1 ) + if $Config; + + $PostambleActionsNoTest = ( + ($missing and not $UnderCPAN) + ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" + : "\$(NOECHO) \$(NOOP)" + ); + + $PostambleActionsUpgradeDepsNoTest = + "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; + + $PostambleActionsListDeps = + '@$(PERL) -le "print for @ARGV" ' + . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); + + my @all = (@Missing, @Existing); + + $PostambleActionsListAllDeps = + '@$(PERL) -le "print for @ARGV" ' + . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); + return %args; } @@ -782,11 +891,15 @@ sub Write { sub postamble { $PostambleUsed = 1; + my $fragment; - return <<"END_MAKE"; + $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) +AUTO_INSTALL + + $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps @@ -794,12 +907,28 @@ checkdeps :: installdeps :: \t$PostambleActions +installdeps_notest :: +\t$PostambleActionsNoTest + +upgradedeps :: +\t$PostambleActionsUpgradeDeps + +upgradedeps_notest :: +\t$PostambleActionsUpgradeDepsNoTest + +listdeps :: +\t$PostambleActionsListDeps + +listalldeps :: +\t$PostambleActionsListAllDeps + END_MAKE + return $fragment; } 1; __END__ -#line 1056 +#line 1197 diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm index 51eda5d..ff767fa 100644 --- a/inc/Module/Install.pm +++ b/inc/Module/Install.pm @@ -17,8 +17,11 @@ package Module::Install; # 3. The ./inc/ version of Module::Install loads # } -use 5.005; +use 5.006; use strict 'vars'; +use Cwd (); +use File::Find (); +use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { @@ -28,7 +31,7 @@ BEGIN { # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. - $VERSION = '0.91'; + $VERSION = '1.14'; # Storage for the pseudo-singleton $MAIN = undef; @@ -38,18 +41,25 @@ BEGIN { } +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; - - - -# Whether or not inc::Module::Install is actually loaded, the -# $INC{inc/Module/Install.pm} is what will still get set as long as -# the caller loaded module this in the documented manner. -# If not set, the caller may NOT have loaded the bundled version, and thus -# they may not have a MI version that works with the Makefile.PL. This would -# result in false errors or unexpected behaviour. And we don't want that. -my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; -unless ( $INC{$file} ) { die <<"END_DIE" } + #------------------------------------------------------------- + # all of the following checks should be included in import(), + # to allow "eval 'require Module::Install; 1' to test + # installation of Module::Install. (RT #51267) + #------------------------------------------------------------- + + # Whether or not inc::Module::Install is actually loaded, the + # $INC{inc/Module/Install.pm} is what will still get set as long as + # the caller loaded module this in the documented manner. + # If not set, the caller may NOT have loaded the bundled version, and thus + # they may not have a MI version that works with the Makefile.PL. This would + # result in false errors or unexpected behaviour. And we don't want that. + my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; + unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: @@ -61,26 +71,28 @@ not: END_DIE - - - - -# If the script that is loading Module::Install is from the future, -# then make will detect this and cause it to re-run over and over -# again. This is bad. Rather than taking action to touch it (which -# is unreliable on some platforms and requires write permissions) -# for now we should catch this and refuse to run. -if ( -f $0 ) { - my $s = (stat($0))[9]; - - # If the modification time is only slightly in the future, - # sleep briefly to remove the problem. - my $a = $s - time; - if ( $a > 0 and $a < 5 ) { sleep 5 } - - # Too far in the future, throw an error. - my $t = time; - if ( $s > $t ) { die <<"END_DIE" } + # This reportedly fixes a rare Win32 UTC file time issue, but + # as this is a non-cross-platform XS module not in the core, + # we shouldn't really depend on it. See RT #24194 for detail. + # (Also, this module only supports Perl 5.6 and above). + eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; + + # If the script that is loading Module::Install is from the future, + # then make will detect this and cause it to re-run over and over + # again. This is bad. Rather than taking action to touch it (which + # is unreliable on some platforms and requires write permissions) + # for now we should catch this and refuse to run. + if ( -f $0 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + my $t = time; + if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). @@ -89,15 +101,12 @@ This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE -} - - - + } -# Build.PL was formerly supported, but no longer is due to excessive -# difficulty in implementing every single feature twice. -if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } + # Build.PL was formerly supported, but no longer is due to excessive + # difficulty in implementing every single feature twice. + if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. @@ -107,36 +116,69 @@ Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE + #------------------------------------------------------------- + # To save some more typing in Module::Install installers, every... + # use inc::Module::Install + # ...also acts as an implicit use strict. + $^H |= strict::bits(qw(refs subs vars)); + #------------------------------------------------------------- + unless ( -f $self->{file} ) { + foreach my $key (keys %INC) { + delete $INC{$key} if $key =~ /Module\/Install/; + } -# To save some more typing in Module::Install installers, every... -# use inc::Module::Install -# ...also acts as an implicit use strict. -$^H |= strict::bits(qw(refs subs vars)); - + local $^W; + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } + local $^W; + *{"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + # Unregister loader and worker packages so subdirs can use them again + delete $INC{'inc/Module/Install.pm'}; + delete $INC{'Module/Install.pm'}; + # Save to the singleton + $MAIN = $self; -use Cwd (); -use File::Find (); -use File::Path (); -use FindBin; + return 1; +} sub autoload { my $self = shift; my $who = $self->_caller; - my $cwd = Cwd::cwd(); + my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { - my $pwd = Cwd::cwd(); + my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } - $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; + unless ($$sym =~ s/([^:]+)$//) { + # XXX: it looks like we can't retrieve the missing function + # via $$sym (usually $main::AUTOLOAD) in this case. + # I'm still wondering if we should slurp Makefile.PL to + # get some context or not ... + my ($package, $file, $line) = caller; + die <<"EOT"; +Unknown function is found at $file line $line. +Execution of $file aborted due to runtime errors. + +If you're a contributor to a project, you may need to install +some Module::Install extensions from CPAN (or other repository). +If you're a user of a module, please contact the author. +EOT + } my $method = $1; if ( uc($method) eq $method ) { # Do nothing @@ -152,33 +194,6 @@ sub autoload { }; } -sub import { - my $class = shift; - my $self = $class->new(@_); - my $who = $self->_caller; - - unless ( -f $self->{file} ) { - require "$self->{path}/$self->{dispatch}.pm"; - File::Path::mkpath("$self->{prefix}/$self->{author}"); - $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); - $self->{admin}->init; - @_ = ($class, _self => $self); - goto &{"$self->{name}::import"}; - } - - *{"${who}::AUTOLOAD"} = $self->autoload; - $self->preload; - - # Unregister loader and worker packages so subdirs can use them again - delete $INC{"$self->{file}"}; - delete $INC{"$self->{path}.pm"}; - - # Save to the singleton - $MAIN = $self; - - return 1; -} - sub preload { my $self = shift; unless ( $self->{extensions} ) { @@ -204,6 +219,7 @@ sub preload { my $who = $self->_caller; foreach my $name ( sort keys %seen ) { + local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; @@ -214,12 +230,18 @@ sub preload { sub new { my ($class, %args) = @_; + delete $INC{'FindBin.pm'}; + { + # to suppress the redefine warning + local $SIG{__WARN__} = sub {}; + require FindBin; + } + # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); - unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { + unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } - return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; @@ -272,8 +294,10 @@ END_DIE sub load_extensions { my ($self, $path, $top) = @_; + my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; + $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { @@ -281,12 +305,13 @@ sub load_extensions { next if $self->{pathnames}{$pkg}; local $@; - my $new = eval { require $file; $pkg->can('new') }; + my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } - $self->{pathnames}{$pkg} = delete $INC{$file}; + $self->{pathnames}{$pkg} = + $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } @@ -313,7 +338,7 @@ sub find_extensions { if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; - foreach ( split //, $content ) { + foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text @@ -348,17 +373,26 @@ sub _caller { return $call; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; - if ( $] >= 5.006 ) { - open( FH, '<', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "< $_[0]" ) or die "open($_[0]): $!"; - } + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; + binmode FH; + my $string = do { local $/; }; + close FH or die "close($_[0]): $!"; + return $string; +} +END_NEW +sub _read { + local *FH; + open( FH, "< $_[0]" ) or die "open($_[0]): $!"; + binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } +END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); @@ -379,22 +413,32 @@ sub _readpod { return $string; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; - if ( $] >= 5.006 ) { - open( FH, '>', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "> $_[0]" ) or die "open($_[0]): $!"; + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + binmode FH; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; } + close FH or die "close($_[0]): $!"; +} +END_NEW +sub _write { + local *FH; + open( FH, "> $_[0]" ) or die "open($_[0]): $!"; + binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } +END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). -sub _version ($) { +sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { @@ -410,12 +454,12 @@ sub _version ($) { return $l + 0; } -sub _cmp ($$) { - _version($_[0]) <=> _version($_[1]); +sub _cmp { + _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS -sub _CLASS ($) { +sub _CLASS { ( defined $_[0] and @@ -427,4 +471,4 @@ sub _CLASS ($) { 1; -# Copyright 2008 - 2009 Adam Kennedy. +# Copyright 2008 - 2012 Adam Kennedy. diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm index 58dd026..475303e 100644 --- a/inc/Module/Install/AutoInstall.pm +++ b/inc/Module/Install/AutoInstall.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -37,12 +37,33 @@ sub auto_install { $self->include('Module::AutoInstall'); require Module::AutoInstall; - Module::AutoInstall->import( + my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); + my %seen; + my @requires = map @$_, map @$_, grep ref, $self->requires; + while (my ($mod, $ver) = splice(@requires, 0, 2)) { + $seen{$mod}{$ver}++; + } + my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; + while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { + $seen{$mod}{$ver}++; + } + my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; + while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { + $seen{$mod}{$ver}++; + } + + my @deduped; + while (my ($mod, $ver) = splice(@features_require, 0, 2)) { + push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; + } + + $self->requires(@deduped); + $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); @@ -52,6 +73,17 @@ sub auto_install { ); } +sub installdeps_target { + my ($self, @args) = @_; + + $self->include('Module::AutoInstall'); + require Module::AutoInstall; + + Module::AutoInstall::_installdeps_target(1); + + $self->auto_install(@args); +} + sub auto_install_now { my $self = shift; $self->auto_install(@_); diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm index 60a74d2..4206347 100644 --- a/inc/Module/Install/Base.pm +++ b/inc/Module/Install/Base.pm @@ -4,7 +4,7 @@ package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; } # Suspend handler for "redefined" warnings @@ -51,13 +51,18 @@ sub admin { #line 106 sub is_admin { - $_[0]->admin->VERSION; + ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; +use vars qw{$VERSION}; +BEGIN { + $VERSION = $Module::Install::Base::VERSION; +} + my $fake; sub new { @@ -75,4 +80,4 @@ BEGIN { 1; -#line 154 +#line 159 diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm index e65e4f6..9929b1b 100644 --- a/inc/Module/Install/Can.pm +++ b/inc/Module/Install/Can.pm @@ -3,13 +3,12 @@ package Module::Install::Can; use strict; use Config (); -use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -29,7 +28,7 @@ sub can_use { eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } -# check if we can run some command +# Check if we can run some command sub can_run { my ($self, $cmd) = @_; @@ -38,14 +37,88 @@ sub can_run { for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; - my $abs = File::Spec->catfile($dir, $_[1]); + require File::Spec; + my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } -# can we locate a (the) C compiler +# Can our C compiler environment build XS files +sub can_xs { + my $self = shift; + + # Ensure we have the CBuilder module + $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); + + # Do we have the configure_requires checker? + local $@; + eval "require ExtUtils::CBuilder;"; + if ( $@ ) { + # They don't obey configure_requires, so it is + # someone old and delicate. Try to avoid hurting + # them by falling back to an older simpler test. + return $self->can_cc(); + } + + # Do we have a working C compiler + my $builder = ExtUtils::CBuilder->new( + quiet => 1, + ); + unless ( $builder->have_compiler ) { + # No working C compiler + return 0; + } + + # Write a C file representative of what XS becomes + require File::Temp; + my ( $FH, $tmpfile ) = File::Temp::tempfile( + "compilexs-XXXXX", + SUFFIX => '.c', + ); + binmode $FH; + print $FH <<'END_C'; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +int main(int argc, char **argv) { + return 0; +} + +int boot_sanexs() { + return 1; +} + +END_C + close $FH; + + # Can the C compiler access the same headers XS does + my @libs = (); + my $object = undef; + eval { + local $^W = 0; + $object = $builder->compile( + source => $tmpfile, + ); + @libs = $builder->link( + objects => $object, + module_name => 'sanexs', + ); + }; + my $result = $@ ? 0 : 1; + + # Clean up all the build files + foreach ( $tmpfile, $object, @libs ) { + next unless defined $_; + 1 while unlink; + } + + return $result; +} + +# Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; @@ -78,4 +151,4 @@ if ( $^O eq 'cygwin' ) { __END__ -#line 156 +#line 236 diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm index 05f2079..3d8de76 100644 --- a/inc/Module/Install/Fetch.pm +++ b/inc/Module/Install/Fetch.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm index 7e792e0..f274f87 100644 --- a/inc/Module/Install/Include.pm +++ b/inc/Module/Install/Include.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm index 98779db..66993af 100644 --- a/inc/Module/Install/Makefile.pm +++ b/inc/Module/Install/Makefile.pm @@ -4,10 +4,11 @@ package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); +use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -25,8 +26,8 @@ sub prompt { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } - # In automated testing, always use defaults - if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { + # In automated testing or non-interactive session, always use defaults + if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { @@ -34,21 +35,112 @@ sub prompt { } } +# Store a cleaned up version of the MakeMaker version, +# since we need to behave differently in a variety of +# ways based on the MM version. +my $makemaker = eval $ExtUtils::MakeMaker::VERSION; + +# If we are passed a param, do a "newer than" comparison. +# Otherwise, just return the MakeMaker version. +sub makemaker { + ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 +} + +# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified +# as we only need to know here whether the attribute is an array +# or a hash or something else (which may or may not be appendable). +my %makemaker_argtype = ( + C => 'ARRAY', + CONFIG => 'ARRAY', +# CONFIGURE => 'CODE', # ignore + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => 'ARRAY', # ignore '' + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + META_ADD => 'HASH', + META_MERGE => 'HASH', + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + CONFIGURE_REQUIRES => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', +# VERSION => ['version',''], # ignore +# _KEEP_AFTER_FLUSH => '', + + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', + + # special cases where you can use makemaker_append + CCFLAGS => 'APPENDABLE', + DEFINE => 'APPENDABLE', + INC => 'APPENDABLE', + LDDLFLAGS => 'APPENDABLE', + LDFROM => 'APPENDABLE', +); + sub makemaker_args { - my $self = shift; + my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); - %$args = ( %$args, @_ ); + foreach my $key (keys %new_args) { + if ($makemaker_argtype{$key}) { + if ($makemaker_argtype{$key} eq 'ARRAY') { + $args->{$key} = [] unless defined $args->{$key}; + unless (ref $args->{$key} eq 'ARRAY') { + $args->{$key} = [$args->{$key}] + } + push @{$args->{$key}}, + ref $new_args{$key} eq 'ARRAY' + ? @{$new_args{$key}} + : $new_args{$key}; + } + elsif ($makemaker_argtype{$key} eq 'HASH') { + $args->{$key} = {} unless defined $args->{$key}; + foreach my $skey (keys %{ $new_args{$key} }) { + $args->{$key}{$skey} = $new_args{$key}{$skey}; + } + } + elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { + $self->makemaker_append($key => $new_args{$key}); + } + } + else { + if (defined $args->{$key}) { + warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; + } + $args->{$key} = $new_args{$key}; + } + } return $args; } -# For mm args that take multiple space-seperated args, +# For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { - my $self = sShift; + my $self = shift; my $name = shift; my $args = $self->makemaker_args; - $args->{name} = defined $args->{$name} - ? join( ' ', $args->{name}, @_ ) + $args->{$name} = defined $args->{$name} + ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } @@ -89,25 +181,22 @@ sub inc { $self->makemaker_args( INC => shift ); } -my %test_dir = (); - sub _wanted_t { - /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; - if ( $self->tests ) { - die "tests_recursive will not work if tests are already defined"; - } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } - %test_dir = (); + my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; - File::Find::find( \&_wanted_t, $dir ); - $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); + File::Find::find( + sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, + $dir + ); + $self->tests( join ' ', sort keys %tests ); } sub write { @@ -126,76 +215,136 @@ sub write { require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { - # MakeMaker can complain about module versions that include - # an underscore, even though its own version may contain one! - # Hence the funny regexp to get rid of it. See RT #35800 - # for details. - $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); - $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); + # This previous attempted to inherit the version of + # ExtUtils::MakeMaker in use by the module author, but this + # was found to be untenable as some authors build releases + # using future dev versions of EU:MM that nobody else has. + # Instead, #toolchain suggests we use 6.59 which is the most + # stable version on CPAN at time of writing and is, to quote + # ribasushi, "not terminally fucked, > and tested enough". + # TODO: We will now need to maintain this over time to push + # the version up as new versions are released. + $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); + $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. - $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); - $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); + $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); + $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; - $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; + $args->{VERSION} = $self->version or die <<'EOT'; +ERROR: Can't determine distribution version. Please specify it +explicitly via 'version' in Makefile.PL, or set a valid $VERSION +in a module, and provide its file path via 'version_from' (or +'all_from' if you prefer) in Makefile.PL. +EOT + if ( $self->tests ) { - $args->{test} = { TESTS => $self->tests }; + my @tests = split ' ', $self->tests; + my %seen; + $args->{test} = { + TESTS => (join ' ', grep {!$seen{$_}++} @tests), + }; + } elsif ( $Module::Install::ExtraTests::use_extratests ) { + # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. + # So, just ignore our xt tests here. + } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + $args->{test} = { + TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), + }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; - $args->{AUTHOR} = $self->author; + $args->{AUTHOR} = join ', ', @{$self->author || []}; } - if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { - $args->{NO_META} = 1; + if ( $self->makemaker(6.10) ) { + $args->{NO_META} = 1; + #$args->{NO_MYMETA} = 1; } - if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { + if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } + if ( $self->makemaker(6.31) and $self->license ) { + $args->{LICENSE} = $self->license; + } - # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, - map { @$_ } + map { @$_ } # flatten [module => version] map { @$_ } grep $_, - ($self->configure_requires, $self->build_requires, $self->requires) + ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; - # merge both kinds of requires into prereq_pm - my $subdirs = ($args->{DIR} ||= []); + # Merge both kinds of requires into BUILD_REQUIRES + my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); + %$build_prereq = ( %$build_prereq, + map { @$_ } # flatten [module => version] + map { @$_ } + grep $_, + ($self->configure_requires, $self->build_requires) + ); + + # Remove any reference to perl, BUILD_REQUIRES doesn't support it + delete $args->{BUILD_REQUIRES}->{perl}; + + # Delete bundled dists from prereq_pm, add it to Makefile DIR + my $subdirs = ($args->{DIR} || []); if ($self->bundles) { + my %processed; foreach my $bundle (@{ $self->bundles }) { - my ($file, $dir) = @$bundle; - push @$subdirs, $dir if -d $dir; - delete $prereq->{$file}; + my ($mod_name, $dist_dir) = @$bundle; + delete $prereq->{$mod_name}; + $dist_dir = File::Basename::basename($dist_dir); # dir for building this module + if (not exists $processed{$dist_dir}) { + if (-d $dist_dir) { + # List as sub-directory to be processed by make + push @$subdirs, $dist_dir; + } + # Else do nothing: the module is already present on the system + $processed{$dist_dir} = undef; + } } } + unless ( $self->makemaker('6.55_03') ) { + %$prereq = (%$prereq,%$build_prereq); + delete $args->{BUILD_REQUIRES}; + } + if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; + + if ( $self->makemaker(6.48) ) { + $args->{MIN_PERL_VERSION} = $perl_version; + } } - $args->{INSTALLDIRS} = $self->installdirs; + if ($self->installdirs) { + warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; + $args->{INSTALLDIRS} = $self->installdirs; + } - my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; + my %args = map { + ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) + } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; - if (my $preop = $self->admin->preop($user_preop)) { + if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } @@ -219,9 +368,9 @@ sub fix_up_makefile { . ($self->postamble || ''); local *MAKEFILE; - open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; - close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; @@ -241,7 +390,8 @@ sub fix_up_makefile { # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; - open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + seek MAKEFILE, 0, SEEK_SET; + truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; @@ -265,4 +415,4 @@ sub postamble { __END__ -#line 394 +#line 544 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm index 653193d..e547fa0 100644 --- a/inc/Module/Install/Metadata.pm +++ b/inc/Module/Install/Metadata.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } @@ -19,7 +19,6 @@ my @scalar_keys = qw{ name module_name abstract - author version distribution_type tests @@ -43,8 +42,11 @@ my @resource_keys = qw{ my @array_keys = qw{ keywords + author }; +*authors = \&author; + sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } @@ -149,15 +151,21 @@ sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { - my $self = shift; - unless ( @_ ) { - warn "You MUST provide an explicit true/false value to dynamic_config\n"; - return $self; + my $self = shift; + my $value = @_ ? shift : 1; + if ( $self->{values}->{dynamic_config} ) { + # Once dynamic we never change to static, for safety + return 0; } - $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; + $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } +# Convenience command +sub static_config { + shift->dynamic_config(0); +} + sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; @@ -168,7 +176,7 @@ sub perl_version { # Normalize the version $version = $self->_perl_version($version); - # We don't support the reall old versions + # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } @@ -176,43 +184,6 @@ sub perl_version { $self->{values}->{perl_version} = $version; } -#Stolen from M::B -my %license_urls = ( - perl => 'http://dev.perl.org/licenses/', - apache => 'http://apache.org/licenses/LICENSE-2.0', - artistic => 'http://opensource.org/licenses/artistic-license.php', - artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', - lgpl => 'http://opensource.org/licenses/lgpl-license.php', - lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', - lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', - bsd => 'http://opensource.org/licenses/bsd-license.php', - gpl => 'http://opensource.org/licenses/gpl-license.php', - gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', - gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', - mit => 'http://opensource.org/licenses/mit-license.php', - mozilla => 'http://opensource.org/licenses/mozilla1.1.php', - open_source => undef, - unrestricted => undef, - restrictive => undef, - unknown => undef, -); - -sub license { - my $self = shift; - return $self->{values}->{license} unless @_; - my $license = shift or die( - 'Did not provide a value to license()' - ); - $self->{values}->{license} = $license; - - # Automatically fill in license URLs - if ( $license_urls{$license} ) { - $self->resources( license => $license_urls{$license} ); - } - - return 1; -} - sub all_from { my ( $self, $file ) = @_; @@ -230,6 +201,8 @@ sub all_from { die("The path '$file' does not exist, or is not a file"); } + $self->{values}{all_from} = $file; + # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; @@ -240,7 +213,7 @@ sub all_from { $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; - $self->author_from($pod) unless $self->author; + $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; @@ -350,6 +323,9 @@ sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); + + # for version integrity check + $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { @@ -360,7 +336,7 @@ sub abstract_from { { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) - ); + ); } # Add both distribution and module name @@ -371,7 +347,7 @@ sub name_from { ^ \s* package \s* ([\w:]+) - \s* ; + [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); @@ -385,11 +361,10 @@ sub name_from { } } -sub perl_version_from { - my $self = shift; +sub _extract_perl_version { if ( - Module::Install::_read($_[0]) =~ m/ - ^ + $_[0] =~ m/ + ^\s* (?:use|require) \s* v? ([\d_\.]+) @@ -398,6 +373,16 @@ sub perl_version_from { ) { my $perl_version = $1; $perl_version =~ s{_}{}g; + return $perl_version; + } else { + return; + } +} + +sub perl_version_from { + my $self = shift; + my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); + if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; @@ -417,59 +402,165 @@ sub author_from { ([^\n]*) /ixms) { my $author = $1 || $2; - $author =~ s{E}{<}g; - $author =~ s{E}{>}g; + + # XXX: ugly but should work anyway... + if (eval "require Pod::Escapes; 1") { + # Pod::Escapes has a mapping table. + # It's in core of perl >= 5.9.3, and should be installed + # as one of the Pod::Simple's prereqs, which is a prereq + # of Pod::Text 3.x (see also below). + $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $Pod::Escapes::Name2character_number{$1} + ? chr($Pod::Escapes::Name2character_number{$1}) + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { + # Pod::Text < 3.0 has yet another mapping table, + # though the table name of 2.x and 1.x are different. + # (1.x is in core of Perl < 5.6, 2.x is in core of + # Perl < 5.9.3) + my $mapping = ($Pod::Text::VERSION < 2) + ? \%Pod::Text::HTML_Escapes + : \%Pod::Text::ESCAPES; + $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $mapping->{$1} + ? $mapping->{$1} + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + else { + $author =~ s{E}{<}g; + $author =~ s{E}{>}g; + } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } -sub license_from { +#Stolen from M::B +my %license_urls = ( + perl => 'http://dev.perl.org/licenses/', + apache => 'http://apache.org/licenses/LICENSE-2.0', + apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', + artistic => 'http://opensource.org/licenses/artistic-license.php', + artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', + lgpl => 'http://opensource.org/licenses/lgpl-license.php', + lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', + lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', + bsd => 'http://opensource.org/licenses/bsd-license.php', + gpl => 'http://opensource.org/licenses/gpl-license.php', + gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', + gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', + mit => 'http://opensource.org/licenses/mit-license.php', + mozilla => 'http://opensource.org/licenses/mozilla1.1.php', + open_source => undef, + unrestricted => undef, + restrictive => undef, + unknown => undef, +); + +sub license { my $self = shift; - if ( - Module::Install::_read($_[0]) =~ m/ - ( - =head \d \s+ - (?:licen[cs]e|licensing|copyright|legal)\b - .*? - ) - (=head\\d.*|=cut.*|) - \z - /ixms ) { - my $license_text = $1; - my @phrases = ( - 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, - 'GNU general public license' => 'gpl', 1, - 'GNU public license' => 'gpl', 1, - 'GNU lesser general public license' => 'lgpl', 1, - 'GNU lesser public license' => 'lgpl', 1, - 'GNU library general public license' => 'lgpl', 1, - 'GNU library public license' => 'lgpl', 1, - 'BSD license' => 'bsd', 1, - 'Artistic license' => 'artistic', 1, - 'GPL' => 'gpl', 1, - 'LGPL' => 'lgpl', 1, - 'BSD' => 'bsd', 1, - 'Artistic' => 'artistic', 1, - 'MIT' => 'mit', 1, - 'proprietary' => 'proprietary', 0, - ); - while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { - $pattern =~ s{\s+}{\\s+}g; - if ( $license_text =~ /\b$pattern\b/i ) { - $self->license($license); - return 1; - } + return $self->{values}->{license} unless @_; + my $license = shift or die( + 'Did not provide a value to license()' + ); + $license = __extract_license($license) || lc $license; + $self->{values}->{license} = $license; + + # Automatically fill in license URLs + if ( $license_urls{$license} ) { + $self->resources( license => $license_urls{$license} ); + } + + return 1; +} + +sub _extract_license { + my $pod = shift; + my $matched; + return __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) + (=head \d.*|=cut.*|)\z + /xms + ) || __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) + (=head \d.*|=cut.*|)\z + /xms + ); +} + +sub __extract_license { + my $license_text = shift or return; + my @phrases = ( + '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, + '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, + 'Artistic and GPL' => 'perl', 1, + 'GNU general public license' => 'gpl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser general public license' => 'lgpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'GNU library general public license' => 'lgpl', 1, + 'GNU library public license' => 'lgpl', 1, + 'GNU Free Documentation license' => 'unrestricted', 1, + 'GNU Affero General Public License' => 'open_source', 1, + '(?:Free)?BSD license' => 'bsd', 1, + 'Artistic license 2\.0' => 'artistic_2', 1, + 'Artistic license' => 'artistic', 1, + 'Apache (?:Software )?license' => 'apache', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'Mozilla Public License' => 'mozilla', 1, + 'Q Public License' => 'open_source', 1, + 'OpenSSL License' => 'unrestricted', 1, + 'SSLeay License' => 'unrestricted', 1, + 'zlib License' => 'open_source', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s#\s+#\\s+#gs; + if ( $license_text =~ /\b$pattern\b/i ) { + return $license; } } + return ''; +} - warn "Cannot determine license info from $_[0]\n"; - return 'unknown'; +sub license_from { + my $self = shift; + if (my $license=_extract_license(Module::Install::_read($_[0]))) { + $self->license($license); + } else { + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; + } } sub _extract_bugtracker { - my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; + my @links = $_[0] =~ m#L<( + https?\Q://rt.cpan.org/\E[^>]+| + https?\Q://github.com/\E[\w_]+/[\w_]+/issues| + https?\Q://code.google.com/p/\E[\w_\-]+/issues/list + )>#gx; my %links; @links{@links}=(); @links=keys %links; @@ -485,7 +576,7 @@ sub bugtracker_from { return 0; } if ( @links > 1 ) { - warn "Found more than on rt.cpan.org link in $_[0]\n"; + warn "Found more than one bugtracker link in $_[0]\n"; return 0; } @@ -497,7 +588,7 @@ sub bugtracker_from { sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); - my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; @@ -532,8 +623,15 @@ sub _perl_version { return $v; } - - +sub add_metadata { + my $self = shift; + my %hash = @_; + for my $key (keys %hash) { + warn "add_metadata: $key is not prefixed with 'x_'.\n" . + "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; + $self->{values}->{$key} = $hash{$key}; + } +} ###################################################################### @@ -607,7 +705,7 @@ sub _write_mymeta_data { my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; - # Overwrite the non-configure dependency hashs + # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; diff --git a/inc/Module/Install/Scripts.pm b/inc/Module/Install/Scripts.pm index a1001f5..fba56ae 100644 --- a/inc/Module/Install/Scripts.pm +++ b/inc/Module/Install/Scripts.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } diff --git a/inc/Module/Install/TestBase.pm b/inc/Module/Install/TestBase.pm index b3f12ea..68bc65a 100644 --- a/inc/Module/Install/TestBase.pm +++ b/inc/Module/Install/TestBase.pm @@ -7,7 +7,7 @@ use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { - $VERSION = '0.11'; + $VERSION = '0.86'; @ISA = 'Module::Install::Base'; } @@ -23,7 +23,3 @@ sub use_test_base { } 1; - -=encoding utf8 - -#line 70 diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm index f2f99df..9706e5f 100644 --- a/inc/Module/Install/Win32.pm +++ b/inc/Module/Install/Win32.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91'; + $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm index 12471e5..dbedc00 100644 --- a/inc/Module/Install/WriteAll.pm +++ b/inc/Module/Install/WriteAll.pm @@ -6,7 +6,7 @@ use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { - $VERSION = '0.91';; + $VERSION = '1.14'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } @@ -26,7 +26,10 @@ sub WriteAll { $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { - $self->makemaker_args( PL_FILES => {} ); + # XXX: This still may be a bit over-defensive... + unless ($self->makemaker(6.25)) { + $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; + } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure diff --git a/inc/Spiffy.pm b/inc/Spiffy.pm index 7b10f7a..0f0eae2 100644 --- a/inc/Spiffy.pm +++ b/inc/Spiffy.pm @@ -1,17 +1,16 @@ #line 1 +use strict; use warnings; package Spiffy; -use strict; -use 5.006001; -use warnings; +our $VERSION = '0.46'; + use Carp; require Exporter; -our $VERSION = '0.30'; our @EXPORT = (); our @EXPORT_BASE = qw(field const stub super); our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); -my $stack_frame = 0; +my $stack_frame = 0; my $dump = 'yaml'; my $bases_map = {}; @@ -38,7 +37,7 @@ sub new { my $method = shift; $self->$method(shift); } - return $self; + return $self; } my $filtered_files = {}; @@ -46,7 +45,7 @@ my $filter_dump = 0; my $filter_save = 0; our $filter_result = ''; sub import { - no strict 'refs'; + no strict 'refs'; no warnings; my $self_package = shift; @@ -54,12 +53,12 @@ sub import { # subclass's boolean_arguments and paired_arguments can conflict, causing # difficult debugging. Consider using something truly local. my ($args, @export_list) = do { - local *boolean_arguments = sub { + local *boolean_arguments = sub { qw( - -base -Base -mixin -selfless - -XXX -dumper -yaml + -base -Base -mixin -selfless + -XXX -dumper -yaml -filter_dump -filter_save - ) + ) }; local *paired_arguments = sub { qw(-package) }; $self_package->parse_arguments(@_); @@ -79,8 +78,8 @@ sub import { unless grep /^XXX$/, @EXPORT_BASE; } - spiffy_filter() - if ($args->{-selfless} or $args->{-Base}) and + spiffy_filter() + if ($args->{-selfless} or $args->{-Base}) and not $filtered_files->{(caller($stack_frame))[1]}++; my $caller_package = $args->{-package} || caller($stack_frame); @@ -91,7 +90,7 @@ sub import { next unless $class->isa('Spiffy'); my @export = grep { not defined &{"$caller_package\::$_"}; - } ( @{"$class\::EXPORT"}, + } ( @{"$class\::EXPORT"}, ($args->{-Base} or $args->{-base}) ? @{"$class\::EXPORT_BASE"} : (), ); @@ -99,7 +98,7 @@ sub import { not defined &{"$caller_package\::$_"}; } @{"$class\::EXPORT_OK"}; - # Avoid calling the expensive Exporter::export + # Avoid calling the expensive Exporter::export # if there is nothing to do (optimization) my %exportable = map { ($_, 1) } @export, @export_ok; next unless keys %exportable; @@ -163,7 +162,7 @@ sub base { sub all_my_bases { my $class = shift; - return $bases_map->{$class} + return $bases_map->{$class} if defined $bases_map->{$class}; my @bases = ($class); @@ -175,10 +174,10 @@ sub all_my_bases { $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; } -my %code = ( - sub_start => +my %code = ( + sub_start => "sub {\n", - set_default => + set_default => " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", init => " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . @@ -189,13 +188,13 @@ my %code = ( " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . " \$_[0]->{%s};\n" . " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", - return_if_get => + return_if_get => " return \$_[0]->{%s} unless \$#_ > 0;\n", - set => + set => " \$_[0]->{%s} = \$_[1];\n", - weaken => + weaken => " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", - sub_end => + sub_end => " return \$_[0]->{%s};\n}\n", ); @@ -223,13 +222,14 @@ sub field { my $code = $code{sub_start}; if ($args->{-init}) { my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; - $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; + my @count = ($fragment =~ /(%s)/g); + $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2); } $code .= sprintf $code{set_default}, $field, $default_string, $field if defined $default; $code .= sprintf $code{return_if_get}, $field; $code .= sprintf $code{set}, $field; - $code .= sprintf $code{weaken}, $field, $field + $code .= sprintf $code{weaken}, $field, $field if $args->{-weak}; $code .= sprintf $code{sub_end}, $field; @@ -274,10 +274,10 @@ sub stub { $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; - *{"${package}::$field"} = - sub { + *{"${package}::$field"} = + sub { require Carp; - Carp::confess + Carp::confess "Method $field in package $package must be subclassed"; } } @@ -301,7 +301,7 @@ sub parse_arguments { push @values, $elem; } } - return wantarray ? ($args, @values) : $args; + return wantarray ? ($args, @values) : $args; } sub boolean_arguments { () } @@ -325,8 +325,8 @@ sub id { package DB; { no warnings 'redefine'; - sub super_args { - my @dummy = caller(@_ ? $_[0] : 2); + sub super_args { + my @dummy = caller(@_ ? $_[0] : 2); return @DB::args; } } @@ -397,7 +397,7 @@ sub spiffy_base_import { my $inheritor = caller(0); for my $base_class (@base_classes) { next if $inheritor->isa($base_class); - croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", + croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", "See the documentation of Spiffy.pm for details\n " unless $base_class->isa('Spiffy'); $stack_frame = 1; # tell import to use different caller @@ -439,7 +439,7 @@ sub spiffy_mixin_methods { $methods{$_} ? ($_, \ &{"$methods{$_}\::$_"}) : ($_, \ &{"$mixin_class\::$_"}) - } @_ + } @_ ? (get_roles($mixin_class, @_)) : (keys %methods); } @@ -450,12 +450,12 @@ sub get_roles { while (grep /^!*:/, @roles) { @roles = map { s/!!//g; - /^!:(.*)/ ? do { - my $m = "_role_$1"; + /^!:(.*)/ ? do { + my $m = "_role_$1"; map("!$_", $mixin_class->$m); } : /^:(.*)/ ? do { - my $m = "_role_$1"; + my $m = "_role_$1"; ($mixin_class->$m); } : ($_) @@ -533,7 +533,3 @@ sub ZZZ { } 1; - -__END__ - -#line 1066 diff --git a/inc/Test/Base.pm b/inc/Test/Base.pm index 0d4d982..b6bf163 100644 --- a/inc/Test/Base.pm +++ b/inc/Test/Base.pm @@ -1,11 +1,22 @@ #line 1 -# TODO: -# package Test::Base; -use 5.006001; -use Spiffy 0.30 -Base; +our $VERSION = '0.88'; + +use Spiffy -Base; use Spiffy ':XXX'; -our $VERSION = '0.59'; + +my $HAS_PROVIDER; +BEGIN { + $HAS_PROVIDER = eval "require Test::Builder::Provider; 1"; + + if ($HAS_PROVIDER) { + Test::Builder::Provider->import('provides'); + } + else { + *provides = sub { 1 }; + } +} + my @test_more_exports; BEGIN { @@ -26,9 +37,9 @@ our @EXPORT = (@test_more_exports, qw( is no_diff blocks next_block first_block - delimiters spec_file spec_string + delimiters spec_file spec_string filters filters_delay filter_arguments - run run_compare run_is run_is_deeply run_like run_unlike + run run_compare run_is run_is_deeply run_like run_unlike skip_all_unless_require is_deep run_is_deep WWW XXX YYY ZZZ tie_output no_diag_on_only @@ -61,7 +72,7 @@ my $default_class; my $default_object; my $reserved_section_names = {}; -sub default_object { +sub default_object { $default_object ||= $default_class->new; return $default_object; } @@ -69,7 +80,7 @@ sub default_object { my $import_called = 0; sub import() { $import_called = 1; - my $class = (grep /^-base$/i, @_) + my $class = (grep /^-base$/i, @_) ? scalar(caller) : $_[0]; if (not defined $default_class) { @@ -92,7 +103,7 @@ sub import() { Test::More->import(import => \@test_more_exports, @args) if @args; } - + _strict_warnings(); goto &Spiffy::import; } @@ -149,14 +160,14 @@ sub blocks() { if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; my $blocks = $self->block_list; - + my $section_name = shift || ''; my @blocks = $section_name ? (grep { exists $_->{$section_name} } @$blocks) : (@$blocks); return scalar(@blocks) unless wantarray; - + return (@blocks) if $self->_filters_delay; for my $block (@blocks) { @@ -227,7 +238,7 @@ sub filters() { if (ref($_[0]) eq 'HASH') { $self->_filters_map(shift); } - else { + else { my $filters = $self->_filters; push @$filters, @_; } @@ -244,23 +255,24 @@ sub have_text_diff { $Algorithm::Diff::VERSION >= 1.15; } +provides 'is'; sub is($$;$) { (my ($self), @_) = find_my_self(@_); my ($actual, $expected, $name) = @_; - local $Test::Builder::Level = $Test::Builder::Level + 1; + local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER; if ($ENV{TEST_SHOW_NO_DIFFS} or not defined $actual or not defined $expected or - $actual eq $expected or - not($self->have_text_diff) or + $actual eq $expected or + not($self->have_text_diff) or $expected !~ /\n./s ) { Test::More::is($actual, $expected, $name); } else { $name = '' unless defined $name; - ok $actual eq $expected, - $name . "\n" . Text::Diff::diff(\$expected, \$actual); + ok $actual eq $expected, $name; + diag Text::Diff::diff(\$expected, \$actual); } } @@ -324,7 +336,7 @@ sub run_is() { for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; - is($block->$x, $block->$y, + is($block->$x, $block->$y, $block->name ? $block->name : () ); } @@ -337,7 +349,7 @@ sub run_is_deeply() { for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; - is_deeply($block->$x, $block->$y, + is_deeply($block->$x, $block->$y, $block->name ? $block->name : () ); } @@ -393,7 +405,7 @@ sub run_is_deep() { for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; - is_deep($block->$x, $block->$y, + is_deep($block->$x, $block->$y, $block->name ? $block->name : () ); } @@ -464,7 +476,7 @@ sub _make_block { } $description =~ s/\s*\z//; $block->set_value(description => $description); - + my $section_map = {}; my $section_order = []; while (@parts) { @@ -501,9 +513,9 @@ sub _spec_init { $spec = ; close FILE; } - else { - $spec = do { - package main; + else { + $spec = do { + package main; no warnings 'once'; ; }; @@ -536,7 +548,7 @@ sub _strict_warnings() { sub tie_output() { my $handle = shift; die "No buffer to tie" unless @_; - tie $handle, 'Test::Base::Handle', $_[0]; + tie *$handle, 'Test::Base::Handle', $_[0]; } sub no_diff { @@ -619,7 +631,7 @@ sub run_filters { join '', @value; my $old = $_; @value = &$function(@value); - if (not(@value) or + if (not(@value) or @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ ) { if ($value[0] && $_ eq $old) { @@ -652,7 +664,7 @@ sub _get_filters { $map_filters = [ $map_filters ] unless ref $map_filters; my @append = (); for ( - @{$self->blocks_object->_filters}, + @{$self->blocks_object->_filters}, @$map_filters, split(/\s+/, $string), ) { @@ -677,8 +689,4 @@ sub _get_filters { } keys(%Test::Base::Block::), qw( new DESTROY ); } -__DATA__ - -=encoding utf8 - -#line 1376 +1; diff --git a/inc/Test/Base/Filter.pm b/inc/Test/Base/Filter.pm index a440ed9..cdef46e 100644 --- a/inc/Test/Base/Filter.pm +++ b/inc/Test/Base/Filter.pm @@ -1,7 +1,4 @@ #line 1 -#. TODO: -#. - #=============================================================================== # This is the default class for handling Test::Base data filtering. #=============================================================================== @@ -339,6 +336,4 @@ sub _write_to { or die "Couldn't close $filename: $!\n"; } -__DATA__ - -#line 639 +1; diff --git a/inc/Test/Builder.pm b/inc/Test/Builder.pm index 795361f..c1f4828 100644 --- a/inc/Test/Builder.pm +++ b/inc/Test/Builder.pm @@ -5,7 +5,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '0.94'; +our $VERSION = '1.001014'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) BEGIN { @@ -24,7 +24,7 @@ BEGIN { require threads::shared; # Hack around YET ANOTHER threads::shared bug. It would - # occassionally forget the contents of the variable when sharing it. + # occasionally forget the contents of the variable when sharing it. # So we first copy the data, then share, then put our copy back. *share = sub (\[$@%]) { my $type = ref $_[0]; @@ -90,7 +90,21 @@ sub create { return $self; } -#line 168 + +# Copy an object, currently a shallow. +# This does *not* bless the destination. This keeps the destructor from +# firing when we're just storing a copy of the object to restore later. +sub _copy { + my($src, $dest) = @_; + + %$dest = %$src; + _share_keys($dest); + + return; +} + + +#line 182 sub child { my( $self, $name ) = @_; @@ -99,29 +113,44 @@ sub child { $self->croak("You already have a child named ($self->{Child_Name}) running"); } - my $child = bless {}, ref $self; - $child->reset; + my $parent_in_todo = $self->in_todo; + + # Clear $TODO for the child. + my $orig_TODO = $self->find_TODO(undef, 1, undef); + + my $class = ref $self; + my $child = $class->create; # Add to our indentation $child->_indent( $self->_indent . ' ' ); - $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH}; + + # Make the child use the same outputs as the parent + for my $method (qw(output failure_output todo_output)) { + $child->$method( $self->$method ); + } + + # Ensure the child understands if they're inside a TODO + if( $parent_in_todo ) { + $child->failure_output( $self->todo_output ); + } # This will be reset in finalize. We do this here lest one child failure # cause all children to fail. $child->{Child_Error} = $?; $? = 0; $child->{Parent} = $self; + $child->{Parent_TODO} = $orig_TODO; $child->{Name} = $name || "Child of " . $self->name; $self->{Child_Name} = $child->name; return $child; } -#line 201 +#line 233 sub subtest { my $self = shift; - my($name, $subtests) = @_; + my($name, $subtests, @args) = @_; if ('CODE' ne ref $subtests) { $self->croak("subtest()'s second argument must be a code ref"); @@ -129,27 +158,59 @@ sub subtest { # Turn the child into the parent so anyone who has stored a copy of # the Test::Builder singleton will get the child. - my $child = $self->child($name); - my %parent = %$self; - %$self = %$child; - my $error; - if( !eval { $subtests->(); 1 } ) { - $error = $@; + my $child; + my $parent = {}; + { + # child() calls reset() which sets $Level to 1, so we localize + # $Level first to limit the scope of the reset to the subtest. + local $Test::Builder::Level = $Test::Builder::Level + 1; + + # Store the guts of $self as $parent and turn $child into $self. + $child = $self->child($name); + _copy($self, $parent); + _copy($child, $self); + + my $run_the_subtests = sub { + # Add subtest name for clarification of starting point + $self->note("Subtest: $name"); + $subtests->(@args); + $self->done_testing unless $self->_plan_handled; + 1; + }; + + if( !eval { $run_the_subtests->() } ) { + $error = $@; + } } # Restore the parent and the copied child. - %$child = %$self; - %$self = %parent; + _copy($self, $child); + _copy($parent, $self); + + # Restore the parent's $TODO + $self->find_TODO(undef, 1, $child->{Parent_TODO}); # Die *after* we restore the parent. die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; - return $child->finalize; + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $finalize = $child->finalize; + + $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; + + return $finalize; +} + +#line 312 + +sub _plan_handled { + my $self = shift; + return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; } -#line 250 +#line 337 sub finalize { my $self = shift; @@ -158,21 +219,26 @@ sub finalize { if( $self->{Child_Name} ) { $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); } + + local $? = 0; # don't fail if $subtests happened to set $? nonzero $self->_ending; # XXX This will only be necessary for TAP envelopes (we think) #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); + local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok = 1; $self->parent->{Child_Name} = undef; - if ( $self->{Skip_All} ) { - $self->parent->skip($self->{Skip_All}); - } - elsif ( not @{ $self->{Test_Results} } ) { - $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); - } - else { - $self->parent->ok( $self->is_passing, $self->name ); + unless ($self->{Bailed_Out}) { + if ( $self->{Skip_All} ) { + $self->parent->skip($self->{Skip_All}, $self->name); + } + elsif ( not @{ $self->{Test_Results} } ) { + $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); + } + else { + $self->parent->ok( $self->is_passing, $self->name ); + } } $? = $self->{Child_Error}; delete $self->{Parent}; @@ -190,17 +256,17 @@ sub _indent { return $self->{Indent}; } -#line 300 +#line 392 sub parent { shift->{Parent} } -#line 312 +#line 404 sub name { shift->{Name} } sub DESTROY { my $self = shift; - if ( $self->parent ) { + if ( $self->parent and $$ == $self->{Original_Pid} ) { my $name = $self->name; $self->diag(<<"FAIL"); Child ($name) exited without calling finalize() @@ -210,7 +276,7 @@ FAIL } } -#line 336 +#line 428 our $Level; @@ -227,12 +293,12 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) $self->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Have_Output_Plan} = 0; + $self->{Done_Testing} = 0; $self->{Original_Pid} = $$; $self->{Child_Name} = undef; $self->{Indent} ||= ''; - share( $self->{Curr_Test} ); $self->{Curr_Test} = 0; $self->{Test_Results} = &share( [] ); @@ -251,12 +317,26 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) $self->{Start_Todo} = 0; $self->{Opened_Testhandles} = 0; + $self->_share_keys; $self->_dup_stdhandles; return; } -#line 414 + +# Shared scalar values are lost when a hash is copied, so we have +# a separate method to restore them. +# Shared references are retained across copies. +sub _share_keys { + my $self = shift; + + share( $self->{Curr_Test} ); + + return; +} + + +#line 520 my %plan_cmds = ( no_plan => \&no_plan, @@ -303,8 +383,7 @@ sub _plan_tests { return; } - -#line 470 +#line 575 sub expected_tests { my $self = shift; @@ -322,7 +401,7 @@ sub expected_tests { return $self->{Expected_Tests}; } -#line 494 +#line 599 sub no_plan { my($self, $arg) = @_; @@ -335,8 +414,7 @@ sub no_plan { return 1; } - -#line 528 +#line 632 sub _output_plan { my($self, $max, $directive, $reason) = @_; @@ -354,7 +432,8 @@ sub _output_plan { return; } -#line 579 + +#line 684 sub done_testing { my($self, $num_tests) = @_; @@ -397,7 +476,7 @@ sub done_testing { } -#line 630 +#line 735 sub has_plan { my $self = shift; @@ -407,7 +486,7 @@ sub has_plan { return(undef); } -#line 647 +#line 752 sub skip_all { my( $self, $reason ) = @_; @@ -421,7 +500,7 @@ sub skip_all { exit(0); } -#line 672 +#line 777 sub exported_to { my( $self, $pack ) = @_; @@ -432,7 +511,7 @@ sub exported_to { return $self->{Exported_To}; } -#line 702 +#line 807 sub ok { my( $self, $test, $name ) = @_; @@ -589,17 +668,15 @@ sub _is_dualvar { no warnings 'numeric'; my $numval = $val + 0; - return $numval != 0 and $numval ne $val ? 1 : 0; + return ($numval != 0 and $numval ne $val ? 1 : 0); } -#line 876 +#line 985 sub is_eq { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_str( \$got, \$expect ); - if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -616,8 +693,6 @@ sub is_num { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_num( \$got, \$expect ); - if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -675,7 +750,7 @@ sub _isnt_diag { DIAGNOSTIC } -#line 973 +#line 1078 sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; @@ -709,30 +784,37 @@ sub isnt_num { return $self->cmp_ok( $got, '!=', $dont_expect, $name ); } -#line 1022 +#line 1127 sub like { - my( $self, $this, $regex, $name ) = @_; + my( $self, $thing, $regex, $name ) = @_; local $Level = $Level + 1; - return $self->_regex_ok( $this, $regex, '=~', $name ); + return $self->_regex_ok( $thing, $regex, '=~', $name ); } sub unlike { - my( $self, $this, $regex, $name ) = @_; + my( $self, $thing, $regex, $name ) = @_; local $Level = $Level + 1; - return $self->_regex_ok( $this, $regex, '!~', $name ); + return $self->_regex_ok( $thing, $regex, '!~', $name ); } -#line 1046 +#line 1151 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); +# Bad, these are not comparison operators. Should we include more? +my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); + sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; - my $test; + if ($cmp_ok_bl{$type}) { + $self->croak("$type is not a valid comparison operator in cmp_ok()"); + } + + my ($test, $succ); my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -741,9 +823,11 @@ sub cmp_ok { my($pack, $file, $line) = $self->caller(); - $test = eval qq[ -#line 1 "cmp_ok [from $file line $line]" -\$got $type \$expect; + # This is so that warnings come out at the caller's level + $succ = eval qq[ +#line $line "(eval in cmp_ok) $file" +\$test = (\$got $type \$expect); +1; ]; $error = $@; } @@ -757,7 +841,7 @@ sub cmp_ok { ? '_unoverload_num' : '_unoverload_str'; - $self->diag(<<"END") if $error; + $self->diag(<<"END") unless $succ; An error occurred while using $type: ------------------------------------ $error @@ -805,28 +889,36 @@ sub _caller_context { return $code; } -#line 1145 +#line 1259 sub BAIL_OUT { my( $self, $reason ) = @_; $self->{Bailed_Out} = 1; + + if ($self->parent) { + $self->{Bailed_Out_Reason} = $reason; + $self->no_ending(1); + die bless {} => 'Test::Builder::Exception'; + } + $self->_print("Bail out! $reason"); exit 255; } -#line 1158 +#line 1279 { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } -#line 1172 +#line 1293 sub skip { - my( $self, $why ) = @_; + my( $self, $why, $name ) = @_; $why ||= ''; + $name = '' unless defined $name; $self->_unoverload_str( \$why ); lock( $self->{Curr_Test} ); @@ -836,7 +928,7 @@ sub skip { { 'ok' => 1, actual_ok => 1, - name => '', + name => $name, type => 'skip', reason => $why, } @@ -853,7 +945,7 @@ sub skip { return 1; } -#line 1213 +#line 1335 sub todo_skip { my( $self, $why ) = @_; @@ -881,7 +973,7 @@ sub todo_skip { return 1; } -#line 1293 +#line 1415 sub maybe_regex { my( $self, $regex ) = @_; @@ -916,7 +1008,7 @@ sub _is_qr { } sub _regex_ok { - my( $self, $this, $regex, $cmp, $name ) = @_; + my( $self, $thing, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); @@ -928,14 +1020,19 @@ sub _regex_ok { } { - ## no critic (BuiltinFunctions::ProhibitStringyEval) - my $test; my $context = $self->_caller_context; - local( $@, $!, $SIG{__DIE__} ); # isolate eval + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval - $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; + # No point in issuing an uninit warning, they'll see it in the diagnostics + no warnings 'uninitialized'; + + $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; + } $test = !$test if $cmp eq '!~'; @@ -944,11 +1041,11 @@ sub _regex_ok { } unless($ok) { - $this = defined $this ? "'$this'" : 'undef'; + $thing = defined $thing ? "'$thing'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; - $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); + $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); %s %13s '%s' DIAGNOSTIC @@ -961,7 +1058,7 @@ DIAGNOSTIC # I'm not ready to publish this. It doesn't deal with array return # values from the code or context. -#line 1389 +#line 1516 sub _try { my( $self, $code, %opts ) = @_; @@ -981,7 +1078,7 @@ sub _try { return wantarray ? ( $return, $error ) : $return; } -#line 1418 +#line 1545 sub is_fh { my $self = shift; @@ -995,7 +1092,7 @@ sub is_fh { eval { tied($maybe_fh)->can('TIEHANDLE') }; } -#line 1461 +#line 1588 sub level { my( $self, $level ) = @_; @@ -1006,7 +1103,7 @@ sub level { return $Level; } -#line 1493 +#line 1620 sub use_numbers { my( $self, $use_nums ) = @_; @@ -1017,7 +1114,7 @@ sub use_numbers { return $self->{Use_Nums}; } -#line 1526 +#line 1653 foreach my $attribute (qw(No_Header No_Ending No_Diag)) { my $method = lc $attribute; @@ -1035,7 +1132,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) { *{ __PACKAGE__ . '::' . $method } = $code; } -#line 1579 +#line 1706 sub diag { my $self = shift; @@ -1043,7 +1140,7 @@ sub diag { $self->_print_comment( $self->_diag_fh, @_ ); } -#line 1594 +#line 1721 sub note { my $self = shift; @@ -1080,7 +1177,7 @@ sub _print_comment { return 0; } -#line 1644 +#line 1771 sub explain { my $self = shift; @@ -1099,7 +1196,7 @@ sub explain { } @_; } -#line 1673 +#line 1800 sub _print { my $self = shift; @@ -1114,20 +1211,21 @@ sub _print_to_fh { return if $^C; my $msg = join '', @msgs; + my $indent = $self->_indent; local( $\, $", $, ) = ( undef, ' ', '' ); # Escape each line after the first with a # so we don't # confuse Test::Harness. - $msg =~ s{\n(?!\z)}{\n# }sg; + $msg =~ s{\n(?!\z)}{\n$indent# }sg; # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\z/; - return print $fh $self->_indent, $msg; + return print $fh $indent, $msg; } -#line 1732 +#line 1860 sub output { my( $self, $fh ) = @_; @@ -1223,8 +1321,8 @@ sub _open_testhandles { open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; - # $self->_copy_io_layers( \*STDOUT, $Testout ); - # $self->_copy_io_layers( \*STDERR, $Testerr ); + $self->_copy_io_layers( \*STDOUT, $Testout ); + $self->_copy_io_layers( \*STDERR, $Testerr ); $self->{Opened_Testhandles} = 1; @@ -1239,14 +1337,22 @@ sub _copy_io_layers { require PerlIO; my @src_layers = PerlIO::get_layers($src); - binmode $dst, join " ", map ":$_", @src_layers if @src_layers; + _apply_layers($dst, @src_layers) if @src_layers; } ); return; } -#line 1857 +sub _apply_layers { + my ($fh, @layers) = @_; + my %seen; + my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; + binmode($fh, join(":", "", "raw", @unique)); +} + + +#line 1993 sub reset_outputs { my $self = shift; @@ -1258,7 +1364,7 @@ sub reset_outputs { return; } -#line 1883 +#line 2019 sub _message_at_caller { my $self = shift; @@ -1279,7 +1385,7 @@ sub croak { } -#line 1923 +#line 2059 sub current_test { my( $self, $num ) = @_; @@ -1312,7 +1418,7 @@ sub current_test { return $self->{Curr_Test}; } -#line 1971 +#line 2107 sub is_passing { my $self = shift; @@ -1325,7 +1431,7 @@ sub is_passing { } -#line 1993 +#line 2129 sub summary { my($self) = shift; @@ -1333,14 +1439,14 @@ sub summary { return map { $_->{'ok'} } @{ $self->{Test_Results} }; } -#line 2048 +#line 2184 sub details { my $self = shift; return @{ $self->{Test_Results} }; } -#line 2077 +#line 2213 sub todo { my( $self, $pack ) = @_; @@ -1354,19 +1460,21 @@ sub todo { return ''; } -#line 2099 +#line 2240 sub find_TODO { - my( $self, $pack ) = @_; + my( $self, $pack, $set, $new_value ) = @_; $pack = $pack || $self->caller(1) || $self->exported_to; return unless $pack; no strict 'refs'; ## no critic - return ${ $pack . '::TODO' }; + my $old_value = ${ $pack . '::TODO' }; + $set and ${ $pack . '::TODO' } = $new_value; + return $old_value; } -#line 2117 +#line 2260 sub in_todo { my $self = shift; @@ -1375,7 +1483,7 @@ sub in_todo { return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; } -#line 2167 +#line 2310 sub todo_start { my $self = shift; @@ -1390,7 +1498,7 @@ sub todo_start { return; } -#line 2189 +#line 2332 sub todo_end { my $self = shift; @@ -1411,7 +1519,7 @@ sub todo_end { return; } -#line 2222 +#line 2365 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self, $height ) = @_; @@ -1426,9 +1534,9 @@ sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) return wantarray ? @caller : $caller[0]; } -#line 2239 +#line 2382 -#line 2253 +#line 2396 #'# sub _sanity_check { @@ -1441,7 +1549,7 @@ sub _sanity_check { return; } -#line 2274 +#line 2417 sub _whoa { my( $self, $check, $desc ) = @_; @@ -1456,7 +1564,7 @@ WHOA return; } -#line 2298 +#line 2441 sub _my_exit { $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) @@ -1464,7 +1572,7 @@ sub _my_exit { return 1; } -#line 2310 +#line 2453 sub _ending { my $self = shift; @@ -1483,6 +1591,26 @@ sub _ending { if( !$self->{Have_Plan} and $self->{Curr_Test} ) { $self->is_passing(0); $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); + + if($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. +FAIL + $self->is_passing(0); + _my_exit($real_exit_code) && return; + } + + # But if the tests ran, handle exit code. + my $test_results = $self->{Test_Results}; + if(@$test_results) { + my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; + if ($num_failed > 0) { + + my $exit_code = $num_failed <= 254 ? $num_failed : 254; + _my_exit($exit_code) && return; + } + } + _my_exit(254) && return; } # Exit if plan() was never called. This is so "require Test::Simple" @@ -1583,7 +1711,7 @@ END { $Test->_ending if defined $Test; } -#line 2498 +#line 2669 1; diff --git a/inc/Test/Builder/Module.pm b/inc/Test/Builder/Module.pm index ffef230..2da34d1 100644 --- a/inc/Test/Builder/Module.pm +++ b/inc/Test/Builder/Module.pm @@ -3,12 +3,12 @@ package Test::Builder::Module; use strict; -use Test::Builder; +use Test::Builder 1.00; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '0.94'; +our $VERSION = '1.001014'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) diff --git a/inc/Test/More.pm b/inc/Test/More.pm index 9d41458..0affbec 100644 --- a/inc/Test/More.pm +++ b/inc/Test/More.pm @@ -10,7 +10,7 @@ use warnings; # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) -# Can't use Carp because it might cause use_ok() to accidentally succeed +# Can't use Carp because it might cause C to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { @@ -18,10 +18,10 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '0.94'; +our $VERSION = '1.001014'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Builder::Module; +use Test::Builder::Module 0.99; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply @@ -38,7 +38,7 @@ our @EXPORT = qw(ok use_ok require_ok BAIL_OUT ); -#line 164 +#line 163 sub plan { my $tb = Test::More->builder; @@ -72,14 +72,14 @@ sub import_extra { return; } -#line 217 +#line 216 sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } -#line 289 +#line 288 sub ok ($;$) { my( $test, $name ) = @_; @@ -88,7 +88,7 @@ sub ok ($;$) { return $tb->ok( $test, $name ); } -#line 367 +#line 371 sub is ($$;$) { my $tb = Test::More->builder; @@ -103,8 +103,9 @@ sub isnt ($$;$) { } *isn't = \&isnt; +# ' to unconfuse syntax higlighters -#line 411 +#line 416 sub like ($$;$) { my $tb = Test::More->builder; @@ -112,7 +113,7 @@ sub like ($$;$) { return $tb->like(@_); } -#line 426 +#line 431 sub unlike ($$;$) { my $tb = Test::More->builder; @@ -120,7 +121,7 @@ sub unlike ($$;$) { return $tb->unlike(@_); } -#line 471 +#line 477 sub cmp_ok($$$;$) { my $tb = Test::More->builder; @@ -128,7 +129,7 @@ sub cmp_ok($$$;$) { return $tb->cmp_ok(@_); } -#line 506 +#line 512 sub can_ok ($@) { my( $proto, @methods ) = @_; @@ -162,67 +163,89 @@ sub can_ok ($@) { return $ok; } -#line 572 +#line 578 sub isa_ok ($$;$) { - my( $object, $class, $obj_name ) = @_; + my( $thing, $class, $thing_name ) = @_; my $tb = Test::More->builder; - my $diag; + my $whatami; + if( !defined $thing ) { + $whatami = 'undef'; + } + elsif( ref $thing ) { + $whatami = 'reference'; - if( !defined $object ) { - $obj_name = 'The thing' unless defined $obj_name; - $diag = "$obj_name isn't defined"; + local($@,$!); + require Scalar::Util; + if( Scalar::Util::blessed($thing) ) { + $whatami = 'object'; + } } else { - my $whatami = ref $object ? 'object' : 'class'; - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); - if($error) { - if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { - # Its an unblessed reference - $obj_name = 'The reference' unless defined $obj_name; - if( !UNIVERSAL::isa( $object, $class ) ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - elsif( $error =~ /Can't call method "isa" without a package/ ) { - # It's something that can't even be a class - $obj_name = 'The thing' unless defined $obj_name; - $diag = "$obj_name isn't a class or reference"; - } - else { - die <_try( sub { $thing->isa($class) } ); + + if($error) { + die <isa on your $whatami and got some weird error. Here's the error. $error WHOA - } - } - else { - $obj_name = "The $whatami" unless defined $obj_name; - if( !$rslt ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } } - my $name = "$obj_name isa $class"; - my $ok; - if($diag) { - $ok = $tb->ok( 0, $name ); - $tb->diag(" $diag\n"); + # Special case for isa_ok( [], "ARRAY" ) and like + if( $whatami eq 'reference' ) { + $rslt = UNIVERSAL::isa($thing, $class); + } + + my($diag, $name); + if( defined $thing_name ) { + $name = "'$thing_name' isa '$class'"; + $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; + } + elsif( $whatami eq 'object' ) { + my $my_class = ref $thing; + $thing_name = qq[An object of class '$my_class']; + $name = "$thing_name isa '$class'"; + $diag = "The object of class '$my_class' isn't a '$class'"; + } + elsif( $whatami eq 'reference' ) { + my $type = ref $thing; + $thing_name = qq[A reference of type '$type']; + $name = "$thing_name isa '$class'"; + $diag = "The reference of type '$type' isn't a '$class'"; + } + elsif( $whatami eq 'undef' ) { + $thing_name = 'undef'; + $name = "$thing_name isa '$class'"; + $diag = "$thing_name isn't defined"; + } + elsif( $whatami eq 'class' ) { + $thing_name = qq[The class (or class-like) '$thing']; + $name = "$thing_name isa '$class'"; + $diag = "$thing_name isn't a '$class'"; } else { + die; + } + + my $ok; + if($rslt) { $ok = $tb->ok( 1, $name ); } + else { + $ok = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); + } return $ok; } -#line 651 +#line 679 sub new_ok { my $tb = Test::More->builder; @@ -231,7 +254,6 @@ sub new_ok { my( $class, $args, $object_name ) = @_; $args ||= []; - $object_name = "The object" unless defined $object_name; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); @@ -240,23 +262,24 @@ sub new_ok { isa_ok $obj, $class, $object_name; } else { - $tb->ok( 0, "new() died" ); + $class = 'undef' if !defined $class; + $tb->ok( 0, "$class->new() died" ); $tb->diag(" Error was: $error"); } return $obj; } -#line 719 +#line 765 -sub subtest($&) { +sub subtest { my ($name, $subtests) = @_; my $tb = Test::More->builder; return $tb->subtest(@_); } -#line 743 +#line 789 sub pass (;$) { my $tb = Test::More->builder; @@ -270,7 +293,52 @@ sub fail (;$) { return $tb->ok( 0, @_ ); } -#line 806 +#line 842 + +sub require_ok ($) { + my($module) = shift; + my $tb = Test::More->builder; + + my $pack = caller; + + # Try to determine if we've been given a module name or file. + # Module names must be barewords, files not. + $module = qq['$module'] unless _is_module_name($module); + + my $code = <ok( $eval_result, "require $module;" ); + + unless($ok) { + chomp $eval_error; + $tb->diag(<builder; my( $pack, $filename, $line ) = caller; + $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { @@ -285,6 +354,8 @@ sub use_ok ($;@) { # for it to work with non-Exporter based modules. $code = <builder; - - my $pack = caller; - - # Try to deterine if we've been given a module name or file. - # Module names must be barewords, files not. - $module = qq['$module'] unless _is_module_name($module); - - my $code = <ok( $eval_result, "require $module;" ); - - unless($ok) { - chomp $eval_error; - $tb->diag(<builder->diag(@_); @@ -493,13 +523,13 @@ sub note { return Test::More->builder->note(@_); } -#line 1138 +#line 1223 sub explain { return Test::More->builder->explain(@_); } -#line 1204 +#line 1289 ## no critic (Subroutines::RequireFinalReturn) sub skip { @@ -527,7 +557,7 @@ sub skip { last SKIP; } -#line 1288 +#line 1373 sub todo_skip { my( $why, $how_many ) = @_; @@ -548,7 +578,7 @@ sub todo_skip { last TODO; } -#line 1343 +#line 1428 sub BAIL_OUT { my $reason = shift; @@ -557,7 +587,7 @@ sub BAIL_OUT { $tb->BAIL_OUT($reason); } -#line 1382 +#line 1467 #'# sub eq_array { @@ -581,6 +611,8 @@ sub _eq_array { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + next if _equal_nonrefs($e1, $e2); + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; @@ -591,6 +623,21 @@ sub _eq_array { return $ok; } +sub _equal_nonrefs { + my( $e1, $e2 ) = @_; + + return if ref $e1 or ref $e2; + + if ( defined $e1 ) { + return 1 if defined $e2 and $e1 eq $e2; + } + else { + return 1 if !defined $e2; + } + + return; +} + sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; @@ -603,9 +650,6 @@ sub _deep_check { local %Refs_Seen = %Refs_Seen; { - # Quiet uninitialized value warnings when comparing undefs. - no warnings 'uninitialized'; - $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. @@ -616,7 +660,7 @@ sub _deep_check { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { - # Shortcut if they're both defined. + # Shortcut if they're both undefined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { @@ -683,7 +727,7 @@ WHOA } } -#line 1515 +#line 1614 sub eq_hash { local @Data_Stack = (); @@ -706,6 +750,8 @@ sub _eq_hash { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; + next if _equal_nonrefs($e1, $e2); + push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; @@ -716,7 +762,7 @@ sub _eq_hash { return $ok; } -#line 1572 +#line 1673 sub eq_set { my( $a1, $a2 ) = @_; @@ -741,6 +787,6 @@ sub eq_set { ); } -#line 1774 +#line 1946 1; diff --git a/lib/SSH/Batch.pm b/lib/SSH/Batch.pm index caf2f6c..7f23196 100644 --- a/lib/SSH/Batch.pm +++ b/lib/SSH/Batch.pm @@ -1,20 +1,24 @@ +# vim:set ft=perl ts=4 sw=4 et + package SSH::Batch; use strict; use warnings; -our $VERSION = '0.024'; +our $VERSION = '0.030'; 1; __END__ +=encoding utf-8 + =head1 NAME SSH::Batch - Cluster operations based on parallel SSH, set and interval arithmetic =head1 VERSION -This document describes SSH::Batch 0.023 released on Jan 4, 2010. +This document describes SSH::Batch 0.030 released on 8 November 2015. =head1 SYNOPSIS @@ -60,9 +64,12 @@ Run command on clusters. (atnodes calls fornodes internally.) # use -w to prompt for password if w/o SSH key (no echo back) $ atnodes hostname '{ps}' -u agentz -w - # or prompt for password if sudo required... + # or prompt for password if both login and sudo are required... $ atnodes 'sudo apachectl restart' '{ps}' -w + # or prompt for password for sudo only... + $ atnodes 'sudo apachectl restart' '{ps}' -W + # run sudo command if tty required... $ atnodes -tty 'sudo apachectl restart' '{ps}' @@ -95,7 +102,7 @@ System administration (sysadmin) is also part of my C<$work>. Playing with a (bi 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. -C allows you to name your clusters using variables and interval/set syntax in your F<~/.fornodesrc> config file. For instance: +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: $ cat ~/.fornodesrc A=foo[01-03].com bar.org @@ -246,6 +253,12 @@ You may have already learned that you can use the C<-u> and C<-p> options to spe $ atnodes 'ls -lh' '{B} + bob@bar[29-31].org:5678' +It's also possible to specify a different rc config file than F<~/.fornodesrc> via the environment variable C. For example, + + export SSH_BATCH_RC=/opt/my-fornodes-rc + +then the file F will be used instead of the default F<~/.fornodesrc> file. + =item Use C<-L> to help grepping the outputs by hostname When managing hundreds or even thousands of machines, it's often more @@ -333,12 +346,11 @@ There's no spesial requirement on the server side ssh service. Even a non-OpenSS Win32 users should replace "make" with "nmake". -=head1 SOURCE CONTROL +=head1 CODE REPOSITORY -You can always get the latest SSH::Batch source from its -public Git repository: +You can always get the latest C source from its public Git repository: - http://github.com/agentzh/sshbatch/tree/master +L If you have a branch for me to pull, please let me know ;) @@ -367,18 +379,25 @@ localhost. =back -=head1 SEE ALSO +=head1 AUTHORS -L, L, L, L, -L, L. +=over -=head1 COPYRIGHT AND LICENSE +=item * -This module as well as its programs are licensed under the BSD License. +Zhang "agentzh" Yichun (章亦春) C<< >> -Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. +=item * + +Liseen Wan (万珣新) C<< >> + +=back + +=head1 COPYRIGHT & LICENSE + +This module as well as its programs are licensed under the BSD License. -Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. +Copyright (C) 2009-2015, Yichun "agentzh" Zhang (章亦春). All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -400,3 +419,8 @@ Neither the name of the Yahoo! China EEEE Works, Alibaba Inc. nor the names of i 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. +=head1 SEE ALSO + +L, L, L, L, +L, L. + diff --git a/lib/SSH/Batch/ForNodes.pm b/lib/SSH/Batch/ForNodes.pm index b14417c..fe69a85 100644 --- a/lib/SSH/Batch/ForNodes.pm +++ b/lib/SSH/Batch/ForNodes.pm @@ -1,9 +1,11 @@ +# vim:set ft=perl ts=4 sw=4 et + package SSH::Batch::ForNodes; use strict; use warnings; -our $VERSION = '0.023'; +our $VERSION = '0.030'; use Set::Scalar; use File::HomeDir; @@ -27,11 +29,14 @@ sub clear_universe () { } sub init_rc () { - my $home = $ENV{SSH_BATCH_HOME} || File::HomeDir->my_home; - if (!defined $home || !-d $home) { - die "Can't find the home for the current user.\n"; + my $rcfile = $ENV{SSH_BATCH_RC} || q(); + if(! $rcfile){ + my $home = $ENV{SSH_BATCH_HOME} || File::HomeDir->my_home; + if (!defined $home || !-d $home) { + die "Can't find the home for the current user.\n"; + } + $rcfile = "$home/.fornodesrc"; } - my $rcfile = "$home/.fornodesrc"; # auto create $rcfile if $rcfile not exists if (! -e $rcfile) { @@ -72,7 +77,7 @@ sub parse_line ($$) { my $rcfile = $_[1]; if (/^\s*([^=\s]*)\s*=\s*(.*)/) { my ($var, $def) = ($1, $2); - if ($var !~ /^\S+$/) { + if ($var !~ /^\w[-\.\w]*$/) { die "Invalid variable name in $rcfile, line $.: ", "$var\n"; } @@ -179,7 +184,7 @@ sub parse_term ($) { local *_ = \($_[0]); if (/^ \{ ( [^}\s]* ) \} $/x) { my $var = $1; - if ($var !~ /^\S+$/) { + if ($var !~ /^\w[-\.\w]*$/) { die "Invalid variable name in term $_: $var\n"; } my $set = $Vars{$var}; @@ -272,6 +277,8 @@ sub expand_wildcards ($) { 1; __END__ +=encoding utf-8 + =head1 NAME SSH::Batch::ForNodes - Expand set arithmetic expression to host list @@ -282,23 +289,33 @@ SSH::Batch::ForNodes - Expand set arithmetic expression to host list use SSH::Batch::ForNodes; SSH::Batch::ForNodes::init_rc(); + # read the config file from env SSH_BATCH_RC or directly ~/.fornodesrc + my $set = SSH::Batch::ForNodes::parse_expr($expr); # set is a Set::Scalar instance: for my $host (sort $set->elements) { print "$host\n"; } -=head1 AUTHOR +=head1 AUTHORS -Agent Zhang (agentzh) C<< >> +=over -=head1 COPYRIGHT AND LICENSE +=item * -This module as well as its programs are licensed under the BSD License. +Yichun "agentzh" Zhang (章亦春) C<< >> -Copyright (c) 2009, Yahoo! China EEEE Works, Alibaba Inc. All rights reserved. +=item * + +Liseen Wan (万珣新) C<< >> + +=back + +=head1 COPYRIGHT & LICENSE + +This module as well as its programs are licensed under the BSD License. -Copyright (C) 2009, Agent Zhang (agentzh). All rights reserved. +Copyright (C) 2009-2015, Yichun "agentzh" Zhang (章亦春). All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/t/atnodes.t b/t/atnodes.t index 3e99cbd..f8bf018 100644 --- a/t/atnodes.t +++ b/t/atnodes.t @@ -27,6 +27,8 @@ Can't find the home for the current user. --- status: 0 --- SKIP + + === TEST 3: no args given --- rc api=api01.foo.com api02.foo.com @@ -54,11 +56,14 @@ OPTIONS: -t Specify timeout for net traffic. -u User account for SSH login. -v Be verbose. - -w Prompt for password (used for login and sudo, + -w Prompt for password (used for both login and sudo, could be privided by SSH_BATCH_PASSWORD). + -W Prompt for password (just for sudo), + should not be used with -w. -P Prompt for passphrase (used for login, could be privided by SSH_BATCH_PASSPHRASE). -tty Pseudo-tty. + -q Run SSH in quiet mode --- status: 1 @@ -113,3 +118,12 @@ Cluster expression: foo.com Cluster set: foo.com --- status: 0 + + +=== TEST 9: -W and -w both show +--- args: -w -W +--- out +--- err +ERROR: Option -w should not be used together with -W. +Use -w to use passowrd for login and sudo, -W for sudo only. +--- status: 1 diff --git a/t/fornodes.t b/t/fornodes.t index e5b0c6d..9403d55 100644 --- a/t/fornodes.t +++ b/t/fornodes.t @@ -30,6 +30,7 @@ Can't open **RC_FILE_PATH** for reading: No such file or directory --- SKIP + === TEST 3: no expr given --- rc api=api01.foo.com api02.foo.com