├── .github └── workflows │ └── dzil_tester.yml ├── .gitignore ├── AUTHORS ├── Build.PL ├── Changes ├── README ├── THANKS ├── TODO ├── bin_PL ├── _build_docs ├── ccon ├── clusterssh_bash_completion.dist ├── crsh ├── cscp.x ├── csftp ├── cssh └── ctel ├── dist.ini ├── lib └── App │ ├── ClusterSSH.pm │ └── ClusterSSH │ ├── Base.pm │ ├── Cluster.pm │ ├── Config.pm │ ├── Getopt.pm │ ├── Helper.pm │ ├── Host.pm │ ├── L10N.pm │ ├── L10N │ └── en.pm │ ├── Range.pm │ ├── Window.pm │ └── Window │ └── Tk.pm └── t ├── 00-load.t ├── 01l10n.t ├── 02base.t ├── 05getopts.t ├── 10host.t ├── 10host_ssh_config ├── 10host_ssh_include ├── 15config.t ├── 15config.t.file1 ├── 15config.t.file2 ├── 15config.t.file3 ├── 20helper.t ├── 30cluster.cannot_read ├── 30cluster.file1 ├── 30cluster.file2 ├── 30cluster.file3 ├── 30cluster.t ├── 30cluster.tag1 ├── 80clusterssh.t ├── bin └── xterm ├── boilerplate.t ├── changes.t ├── external_cluster_command ├── perltidyrc ├── pod-coverage.t ├── pod.t └── range.t /.github/workflows/dzil_tester.yml: -------------------------------------------------------------------------------- 1 | name: CI test builds 2 | 3 | on: 4 | push: 5 | branches: '*' 6 | pull_request: 7 | branches: '*' 8 | 9 | jobs: 10 | perl-job: 11 | runs-on: ubuntu-latest 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | perl-version: 16 | - 'devel' 17 | - 'latest' 18 | - '5.40' 19 | - '5.38' 20 | - '5.36' 21 | - '5.34' 22 | - '5.32' 23 | - '5.30' 24 | - '5.28' 25 | - '5.26' 26 | - '5.24' 27 | - '5.22' 28 | - '5.20' 29 | - '5.18' 30 | - '5.16' 31 | include: 32 | - perl-version: '5.38' 33 | os: ubuntu-latest 34 | coverage: true 35 | container: 36 | image: perldocker/perl-tester:${{ matrix.perl-version }} 37 | 38 | name: Perl ${{ matrix.perl-version }} 39 | 40 | steps: 41 | - uses: actions/checkout@main 42 | - name: Amend PATH 43 | run: echo "${GITHUB_WORKSPACE}/t/bin" >> $GITHUB_PATH 44 | - name: Current env 45 | run: env 46 | - name: Perl info 47 | run: perl -V 48 | - name: CPAN test modules 49 | run: cpanm -n Pod::Coverage::TrustPod Test::Perl::Critic Test::Pod::Coverage Test::Pod Test::Trap 50 | - name: CPAN build modules 51 | run: cpanm -n Tk X11::Protocol X11::Protocol::Other 52 | - name: Initial Build 53 | run: perl Build.PL 54 | - name: Build the MANIFEST 55 | run: perl Build manifest 56 | - name: Test suite 57 | if: ${{ !matrix.coverage }} 58 | run: perl Build test 59 | env: 60 | RELEASE_TESTING: 1 61 | AUTHOR_TESTING: 1 62 | - name: Coverage tests 63 | if: ${{ matrix.coverage }} 64 | run: perl Build test 65 | env: 66 | COVERAGE: 1 67 | RELEASE_TESTING: 1 68 | AUTHOR_TESTING: 1 69 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /App-* 2 | *.bak 3 | /bin 4 | /blib/ 5 | /_build/ 6 | /.build/ 7 | /Build 8 | Build.PL.orig 9 | Build.PL.x 10 | /cover_db/ 11 | /Makefile 12 | /MANIFEST.bak 13 | /MYMETA.json 14 | /MYMETA.yml 15 | /pm_to_blib 16 | *.swp 17 | *.tar.gz 18 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Authors of clusterssh 2 | 3 | This utility was written by Duncan Ferguson (duncan_ferguson@users.sf.net). 4 | 5 | $Id$ 6 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | use lib 'inc'; 2 | 3 | require Module::Build; 4 | 5 | my %module_build_args = ( 6 | module_name => 'App::ClusterSSH', 7 | dist_abstract => "Cluster administration tool", 8 | ##{ $plugin->get_prereqs(1) ##} 9 | ##{ $plugin->get_default('share_dir') ##} 10 | script_files => [ 11 | 'bin/cssh', 'bin/csftp', 12 | 'bin/ccon', 'bin/crsh', 13 | 'bin/ctel', 'bin/clusterssh_bash_completion.dist' 14 | ], 15 | PL_files => { 16 | 'bin_PL/_build_docs' => [ 17 | 'bin/cssh', 'bin/csftp', 18 | 'bin/ccon', 'bin/crsh', 19 | 'bin/ctel', 'bin/clusterssh_bash_completion.dist' 20 | ], 21 | }, 22 | ); 23 | 24 | unless ( eval { Module::Build->VERSION(0.4004) } ) { 25 | my $tr = delete $module_build_args{test_requires}; 26 | my $br = $module_build_args{build_requires}; 27 | for my $mod ( keys %$tr ) { 28 | if ( exists $br->{$mod} ) { 29 | $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; 30 | } 31 | else { 32 | $br->{$mod} = $tr->{$mod}; 33 | } 34 | } 35 | } # end unless Module::Build is 0.4004 or newer 36 | 37 | my $builder = Module::Build->new(%module_build_args); 38 | $builder->create_build_script; 39 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for {{$dist->name}} 2 | 3 | 4.18 2024-10-19 Duncan Ferguson 4 | - Re-release due to poor release upload to CPAN 5 | 6 | 4.17 2024-10-16 Duncan Ferguson 7 | - Swap the hostname lookup macro from DNS to using the system hostname (Github issue #158) 8 | - Swap from using Travis-CI to Github Actions 9 | - Fix tests on perl 5.38 and 5.40 (Github Issue #153) 10 | 11 | 4.16 2020-06-20 Duncan Ferguson 12 | - Further fix for 'resolve_names' error when adding hosts via the UI 13 | - Fix missing space separator for ssh_args (thanks to Petr Vorel) 14 | 15 | 4.15 2020-05-18 Duncan Ferguson 16 | - Include all utilies within each man page 17 | - Add in 'command_pre' and 'command_post' configuration options 18 | - Fix 'Add Host' menu error finding 'resolved_names' 19 | - Ensure lib path is added to range tests to find the libraries 20 | - Mark permission test as TODO as it appears to be inconsistent 21 | 22 | 4.14 2019-08-21 Duncan Ferguson 23 | - Include README within the repository, not just created tar.gz files 24 | - Add 'autoquit' setting to 'File' menu (Github issue #114) 25 | - Correct macro_hostname to be the FQDN of the server where cssh is being run (Github issue #116) 26 | - Add in user defined macros 27 | 28 | 4.13.2_02 2019-01-14 Duncan Ferguson 29 | - Fix Getopt-Long minimum version 30 | - Fix excess test output when Sort::Naturally isn't installed 31 | 32 | 4.13.2_01 2018-11-24 Duncan Ferguson 33 | - Move all Tk code into its own module as-is 34 | - Fix for 'bad pad value "3m"' error when using Tk 804.034 35 | - Update to Perl::Tidy 20181117 36 | - Convert to using Dist::Zilla 37 | 38 | 4.13.2 2018-03-14 Duncan Ferguson 39 | - Fix for running builds in parallel 40 | - Improvements to SUPPORT and REPORTING BUGS sections in documentation 41 | 42 | 4.13.1 2018-03-05 Duncan Ferguson 43 | - Minor update to fix failing tests due to 3rd party perltidy changes 44 | 45 | 4.13 2017-12-27 Duncan Ferguson 46 | - Ensure ssh_args is keep unset if it is emptied in the configuration file 47 | - Obey configured console position (Debian bug 758215) (Github issue #100) 48 | 49 | 4.12 2017-12-23 Duncan Ferguson 50 | - Fix 'undefined value' error 51 | 52 | 4.11 2017-12-22 Duncan Ferguson 53 | - Fix for multiple range expansion, as in 'h{a,b}{1,2}' (Github issue #97) (Thanks to lazyfrosch) 54 | - Upgrade Perl::Tidy requirement to version 20171214 (Github issue #99) (Thanks to eserte) 55 | - Add in 'external command pipe' to allow for some commands being passed in from the command line 56 | 57 | 4.10_02 2017-08-08 Duncan Ferguson 58 | - Include coverage tests in the resources 59 | - Include the version of cssh in the utility documentation and README 60 | - Fix dashes (-) not being accepted in hostname range expansion (Github issue #89) 61 | - Amend ranges to work on ports, FQDN's and IP addresses 62 | - Fix bug tracker links in the main documentation (Github issue #92) 63 | - New options to specify --rows, --columns and --fillscreen (Github pull request #88) (Thanks to AsharLohmar) 64 | 65 | 4.10_01 2017-04-12 Duncan Ferguson 66 | - Allow 'include' directives when reading SSH configuration files (Github issue #77) (thanks to Azenet) 67 | - Generate README when creating the distribution from cssh man page so www.cpan.org and www.metacpan.org can display documentation 68 | 69 | 4.09 2017-03-11 Duncan Ferguson 70 | - Add perl-5.24 Travis-CI automated testing config 71 | - Correct a logic bug around the --debug option (Github issue #75) 72 | - Fix 'Re-add closed windows' not using the correct username (Github issue #72) 73 | - Update copyright year 74 | - Make WM decorations algorithm configurable as causes problems on some systems (Debian bug 842965, re Github pull request #66) (thanks to Tony Mancill) 75 | 76 | 4.08 2016-10-18 Duncan Ferguson 77 | - Add perl-5.8, 5.10 and 5.12 to Travis-CI automated testing 78 | - Fix building and testing on perl-5.8.9 79 | - Improve testing on systems that do not have xterm installed 80 | - Take into account WM decorations when tiling (Github pull request #66) (thanks to Andrew Stevenson) 81 | - Add option in the config file to hide the menu (Github issue #69) 82 | - Add 'unique_servers' into the configuration file to match command line option (Github issue #70) 83 | 84 | 4.07 2016-04-30 Duncan Ferguson 85 | - Fixed tests on systems where bash is not installed in /bin/bash (Github issue #60) 86 | - Include link to travis-ci site in release emails for automated build and test reports 87 | - Rework hostname expansion to be pure-perl rather than relying on the bash shell (Github issue #53) 88 | 89 | 4.06 2016-03-26 Duncan Ferguson 90 | - Failure to find the terminal binary should not be fatal 91 | - Fix processing of '--extra_tag_file' and its configuration item (Github issue #51) 92 | - Add bash shell expansion on host names containing a '{' character (Github issue #53) 93 | - Fix tests when running on a server without xterm installed (such as Travis CI via GitHub) 94 | - Expand $HOME and ~ correctly when looking for files (thanks to Andrew Stevenson) 95 | - Typo correction in README (thanks to Ankit Vadehra) 96 | 97 | 4.05 2015-11-28 Duncan Ferguson 98 | - Change default key_quit from 'Control-q' to 'Alt-q' (Github issue #50) 99 | - Amend tests to always use C locale as some error messages are hardcoded in English (Github issue #49) 100 | 101 | 4.04_01 2015-11-21 Duncan Ferguson 102 | - Ensure documentation is generated using same perl as the build (Github issue #45) 103 | - Pass '--action' through macro parsing (Github issue #42) 104 | - Workaround for glitch in KDE where windows can become unmoveable (Github issue #46) (thanks to Brandon Perkins) 105 | - Add in '--quiet | -Q ' option to reduce output in certian scenarios 106 | - Add in 'csftp' command 107 | 108 | 4.04 2015-11-03 Duncan Ferguson 109 | - Include bash completion script in distribution (Github issue #29) 110 | - Allow re-adding closed session (Github issue #27 - thanks to Andrew Stevenson) 111 | - Allow sorting windows in natural order (Github issue #28 - thanks to Andrew Stevenson) 112 | - Fix links in metadata files to trackers (Github issue #41) 113 | - Fix ctel and ccon not working correctly (Github issue #35) 114 | - Amend t/10host.t to use a random hostname to prevent clashes (Github issue #23) 115 | - Amend copyright message in README to match all other files for the perl license (Github issue #44) 116 | 117 | 4.03_06 2015-01-31 Duncan Ferguson 118 | - Remove references to 'logmsg' preventing the history window from working (thanks to Andrew Stevenson) 119 | 120 | 4.03_05 2014-12-20 Duncan Ferguson 121 | - Fix options parsing tests picked up via cpantesters on different version of perl 122 | 123 | 4.03_04 2014-12-12 Duncan Ferguson 124 | - Do not use system perl but whatever is found in PATH (to stop breaking perlbrew based builds) 125 | - Warn when the configured terminal isn't installed/found 126 | - Don't show 'Opening to:' when no servers are given 127 | 128 | 4.03_03 2014-09-28 Duncan Ferguson 129 | - Force tests to have English locale when user has something else set (Github issue: 10) (thanks to Emanuele Tomasi) 130 | - Skip permissions check test when run as root as the results are invalid (Github issue: 11) (thanks to Deny Dias) 131 | - Ensure config file option for ssh_args is not lost when options is not used on command line (Github issue: 14) 132 | - New Send menu option to send a numeric value between 1 and 1024 (thanks to cqexbesd) 133 | - Remove all history when history window closed (thanks to Bill Rushmore) 134 | 135 | 4.03_02 2014-08-10 Duncan Ferguson 136 | - Fix behaviour when external cluster command is not defined or doesn't exist 137 | 138 | 4.03_01 2014-07-09 Duncan Ferguson 139 | - Amended host parsing to include alternative IPv6 address port definitions, e.g. 1::2::3::4/5567 140 | - List available external tags with -L option and also add into 'Add Host' in UI 141 | [NOTE: Some options have changed!] 142 | - Rework options code 143 | 144 | 4.02_05 0000-00-00 Duncan Ferguson (unreleased) 145 | - Add in 'Set all active' and 'Set half active' host menu options (thanks to Andrew Stevenson) 146 | 147 | 4.02_04 2014-05-17 Duncan Ferguson 148 | - Amend 'Changes' file format to match CPAN specs (see CPAN::Changes) 149 | - Correct autoclose short option to what is actually used (Github issue 4) (thanks to Simon Fraser) 150 | - Fix 'use_all_a_records' option (Github issue: 5) (thanks to Simon Fraser) 151 | - Fix 'title' option (thanks to Barry Roberts) 152 | - Fix 'Add host or cluster' window to contain cluster names 153 | 154 | 4.02_03 2014-01-31 Duncan Ferguson 155 | - Fix 'File->Show History' (Sf support request 41) 156 | - Amend 'tag-file' short option to 'r' to avoid option clash 157 | 158 | 4.02_02 2014-01-13 Duncan Ferguson 159 | - Fixed macros (%u, %s, %h, %n) not doing multiple replacements 160 | - Add in key shortcut for username macro (ALT-u) 161 | - Add in key shortcut for local hostname macro (ALT-l) 162 | - Fix a bug with 'show history' key shortcut 163 | - Fix "uninitialised errors in hash element" bug [clusterssh support-requests:#38] 164 | - Fixed the default cluster not being opened 165 | - Add in toggle for macros 166 | 167 | 4.02_01 2013-04-16 Duncan Ferguson 168 | - Refactured file loading code 169 | - Add in 'tags' file handling 170 | - Fix bug whereby cluster files were read in multiple times 171 | - Add in resolving tags by external command 172 | - Fix library path on bin/cssh (Sf bug 3610601) 173 | 174 | 4.01_05 2013-03-05 Duncan Ferguson 175 | - New option (-m, --unique-servers) to remove repeated servers when opening terminals (Thanks to Oliver Meissner) 176 | - Drop MYMETA.yml and .json files from the distribution 177 | - Do not set default user name to prevent overriding ssh configuration 178 | 179 | 4.01_04 2013-02-26 Duncan Ferguson 180 | - Fixed 'ccon' not calling the correct command (Sf bug 3605002) 181 | - Fixed clusters not being defined correctly within the .clusterssh/config file (Sf bug 3605675) 182 | 183 | 4.01_03 2013-02-15 Duncan Ferguson 184 | - Correct documentation for references to $HOME/.clusterssh/config 185 | - Re-add user back into the configurartion file 186 | - Add in missing newline for some error messages 187 | - Allow the path to rsh/ssh/telnet to be defined in the configuration file 188 | - Move .csshrc to .csshrc.DISABLED since it should no longer be used 189 | - Error emitted when adding a host via the "Hosts" drop-down (Debian bug ID #578208) 190 | - Pastes uses a strange keyboard layout (Debian bug ID #364565) 191 | - Cope with being invoked by 'clusterssh' (Debian bug ID #644368) 192 | - Fix migration of .csshrc when not working as expected (Debian bug ID #673507) 193 | - Remove doc references to 'always_tile' as renamed 'window_tiling' (Debian bug ID #697371) 194 | - Updated manpage whatis entries (patch by Tony Mancill) 195 | - Fix watch line expression to catch 4.x series tarballs (Debian patch LP ID #1076897) 196 | - Allow tests to pass successfully when run as root 197 | - Fix cssh starting if xterm is not installed (Sf bug 3494988) 198 | - Set WM_CLASS on windows to 'cssh' (Sf bug 3187736) 199 | 200 | 4.01_02 2012-12-09 Duncan Ferguson 201 | - Fix logic when using 'autoclose' on the command line or config file 202 | - Fix $HOME/.clusterssh/clusters being read in 203 | - Fix 'ctel', 'crsh' and 'ccon'so they work as expected 204 | 205 | 4.01_01 2011-12-09 Duncan Ferguson 206 | - Include missing files from release tarballs 207 | 208 | 4.01_00 2011-12-03 Duncan Ferguson 209 | - Start switching code to use Exception::Class 210 | - Moved config file from $HOME/.csshrc file to $HOME/.clusterssh directory 211 | - Rework config handling into a module 212 | - Rework cluster handling into a module 213 | - Added 'autoclose' functionality - see docs 214 | - Allow "-a 'cmd ; cmd'" to work for multiple remote commands 215 | 216 | 4.00_11 2011-07-28 Duncan Ferguson 217 | - Fix '-l ' option (SF bug 3380675) 218 | 219 | 4.00_10 2011-07-08 Duncan Ferguson 220 | - Fix 'uninitialised error' message 221 | 222 | 4.00_09 2011-06-30 Duncan Ferguson 223 | - Cater for missing 'pod2text' command (Thanks to Sami Kerola) 224 | - Fix 'uninitialised variable' error 225 | - Added 'ccon' command (Thanks to Brandon Perkins) 226 | 227 | 4.00_08 2011-04-01 Duncan Ferguson 228 | - Amend all L links to prevent build breakage on cygwin (Sf bug 3115635) 229 | 230 | 4.00_07 2011-01-24 Duncan Ferguson 231 | - Fix for parsing config files with empty values (Stefan Steiner) 232 | - Reinstate acting on '-l username' option (reported by Ryan Brown) 233 | 234 | 4.00_06 2010-09-20 Duncan Ferguson 235 | - Fix test error on 5.8.8 (reported by Wei Wang) 236 | - Added '--list', '-L' to list available cluster tags (idea from Markus Manzke) 237 | - Fix terminal size only set on last windows (Sf bug 3061999) 238 | - Added '--use_all_a_records' (Simon Fraser) 239 | 240 | 4.00_05 2010-06-20 Duncan Ferguson 241 | 242 | - Tidy up pod for whatis errors 243 | - Amend copyright years and text to be consistent 244 | - Include missing buld prereq (Test::Trap) 245 | - Correct '--font, -f' in cssh documentation 246 | - Thanks to Tony Mancill for reporting these errors 247 | 248 | 4.00_04 2010-06-20 Duncan Ferguson 249 | 250 | - Update MANIFEST file to ensure all correct files are included in release 251 | 252 | 4.00_03 2010-06-20 Duncan Ferguson 253 | 254 | - Fix silly type in code/tests 255 | 256 | 4.00_02 2010-06-19 Duncan Ferguson 257 | 258 | - Add in bugtracker and homepage resources to Build.PL file 259 | - Bring new module App::ClusterSSH::Host into play for parsing host strings 260 | - Patch to override font used on command line (Roland Rosenfeld) 261 | - Put options in cssh pod into alphabetical order 262 | 263 | 4.00_01 2010-01-08 Duncan Ferguson 264 | 265 | - Remove GNU tools and switch to Perl module layout using Module::Build 266 | 267 | 3.29 0000-00-00 Duncan Ferguson (unreleased) 268 | 269 | - Handle hostnames containing % properly (Debian bug 543368) 270 | - Thanks to Tony Mancill for the patch 271 | 272 | 3.28 2009-12-19 Duncan Ferguson 273 | 274 | - Look for usernames when adding clusters 275 | - Thanks to Kristian Lyngstol for the patch 276 | - Allow username@cluster to override all usernames in the cluster 277 | - Account for multiple host definitions within ssh configuration file 278 | - Thanks to anonymous for the patch 279 | - Allow for long line continuation in config files with a backslash 280 | - Thanks to Mike Loseke for the patch 281 | - Improve binary search to 282 | - ignore directories of the same name, and 283 | - always search for the binary if it is not fully qualified 284 | - Thanks to Ian Marsh for the patch 285 | - Always use the given host name, not the resolved host name, when opening the ssh connection (Debian bug 533406) 286 | 287 | 3.27 2009-09-24 Duncan Ferguson 288 | 289 | - Add in list of clusters to 'Add Host' window 290 | - thanks for Stanislas Rouvelin for the idea 291 | - Fix bug where unresolvable host stopped program running 292 | - thanks to Sami Kerola 293 | - Add in config for auto-tearoff of send and host menus 294 | - thanks to James Chernikov for the idea 295 | - Add in send menu xml definition file 296 | - thanks to James Chernikov for the idea 297 | 298 | 3.26_1 2009-06-02 Duncan Ferguson 299 | 300 | - Allow user to set a different ConnectTimeout and -o string (Tony Mancill) 301 | - Fix warning from 'mandb' (Tony Mancill) 302 | - Continue connecting to unresolvable hosts (debian bug 499935) (Tony Mancill) 303 | - Correct bug with unset default ports (Tony Mancill) 304 | - Rearrange pod documentation to remove extraenous comment (Tony Mancill) 305 | - Cope better with IPv6 addresses 306 | - Fix bug with passing arguments from command line to comms method binary 307 | - Rework defaultport code 308 | - Add new "-a 'command'" option for running a command in each terminal 309 | - Fix bug with some host lookups failing 310 | - Set window hints on terminals slightly differently to help with tiling 311 | - Reserve 5 pixels on top and left hand side of terminals for better tiling 312 | - Increase reserve of screen from bottom from 40 pixels to 60 313 | - Better notes in docs for screen/terminal reserving 314 | - Minor fixup to docs formatting 315 | - Correct pasting mechanism into control window 316 | - Allow use of long options (swap Getopt::Std to Getopt::Long) 317 | - Remove deprecated '-i' option 318 | - Deprecate -d and -D, replaced with --debug 319 | - Allow for configurable max number of hosts within hosts menu before 320 | starting a new column - see .csshrc doc for "max_host_menu_items". 321 | This is until Tk allows for scrollable menus 322 | - Amend default key_addhost from 'Control-plus' to 'Control-Shift-plus' 323 | - Add in a 'default' cluster tag, used when no tags provided on command line 324 | - Fix Alt-n pasting in a resolved hostname instead of the connection hostname 325 | - Disabled unmapping code until such time as a better way of doing it exists 326 | - this is due to virtual desktop change triggering a retile 327 | 328 | 3.25_1 2009-03-26 Duncan Ferguson 329 | 330 | - Add patch from David F. Skoll for adding colour to terminals 331 | - Apply fix from Bogdan Pintea for DNS failing to resolve IPs 332 | - Allow the configuration files to be symlinks (debian bug 518196) 333 | - Add an 'EXAMPLES' section to the cssh documentation 334 | - List options alphabetically in documentation 335 | - Apply patch from Gerfried Fuchs/Tony Mancill for ports on the command line 336 | 337 | 3.24_1 2008-11-14 Duncan Ferguson 338 | 339 | - Do not attempt to re-resolve IP addresses 340 | - Apply patch from Dan Wallis 341 | - Add '-C ' command to load in specific config file 342 | - Typo correct in pod 343 | - Cope with random/strange config files better 344 | - Correct some minor typos 345 | - Create the .csshrc file if it doesnt already exist and amend pod 346 | - Amend host menu items to be a little more descriptive 347 | - Remove 'Catpure Terminal' from Hosts menu as it doesnt do anything useful 348 | 349 | 3.23_1 2008-01-23 Duncan Ferguson 350 | 351 | - Apply bugfix supplied by Jima 352 | - Ensure loading of hosts from user ssh config file is case insensitive 353 | 354 | 3.22_1 2008-01-23 Duncan Ferguson 355 | 356 | - Update X resources class to allow use of terms other than XTerm 357 | - Apply patch from Harald Weidner to stop error messages in Debian Etch 358 | - Add in key shortcut (alt-h) to toggle history window 359 | - Tidy up pod a little to highlight notes better 360 | - Check terminal_font config for quotes and remove 361 | - Enable use of "configure --sysconfdir=", defaults to /etc 362 | - Revise host checking algorithm to take ssh_config files into account 363 | - Revise username check used as part of host id to accept more chars 364 | - Correct year value for previous two entries from 2008 to 2007 365 | 366 | 3.21_1 2007-11-28 Duncan Ferguson 367 | 368 | - Implement a basic history window in the console (option -s) 369 | - Fixed bug whereby username@ wasn't being used correctly 370 | 371 | 3.20_1 2007-11-26 Duncan Ferguson 372 | 373 | - Move source repository from CVS to SVN on sourceforge 374 | - Remove last digit of version number since not required with SVN 375 | - Add in host menu option to close inactive windows 376 | - Apply bugfixes suppled by Tony Mancill 377 | - reset xrm switch in terminal_args 378 | - prevent warning messages being printed when keysyms arent found 379 | - fixes for fvwm 380 | - chekc for child process before sending kill 381 | - Slight rewording of man page 382 | - Add in option to use telnet as comms command (use 'ctel' to invoke script) 383 | - Run through perltidy -b -i=2 384 | - Appy patches from Klaus Ethgen 385 | - Client dies when cannot write to pipe 386 | - Sleeping and flushing in window manager to allow time to draw windows 387 | - Fix pipe reading to not use undefined values 388 | - Apply patches from Nicolas Simonds 389 | - allow colons in hostnames 390 | - allow -o option as per man page 391 | - Apply patch from Peter Palfrader 392 | - improvement to finding binaries 393 | - Allow font to be specified on the command line 394 | - Check for errors around key data gathering 395 | - Add in 'extra_cluster_file' to csshrc 396 | 397 | 3.19.1_1 2006-07-24 Duncan Ferguson 398 | 399 | - Below is an abridged version of changes - see CVS for more information 400 | - Check for failure to connect to X session 401 | - Totally rework character mapping and events to cope with non-QWERTY keyboards 402 | - Rework pasting code to cope with non-QWERTY charatcters 403 | - Manpage/help doc updates and corrections 404 | - Check for missing definitions for cluster tags in .csshrc 405 | - Run through perltidy -b -i=2 406 | - Apply patch to add in optional port information from D. Dumont 407 | - Amend hotkey code to not pick up - as default clientname shortcut 408 | - Alter repeat function to improve efficiency 409 | - Rework retiling code 410 | - Add "-e " to evaluate terminal and communcation methods 411 | - Add in toggle option on hosts menu 412 | - Fix check in find_binary to ensure one is actually found 413 | - Search $PATH and other standard places for binaries incase $PATH is incomplete 414 | - Amend code to allow getting help when no X display available 415 | - Allow override of both key and mouse paste key sequences 416 | - Added icons and desktop file 417 | - Amended clusterssh.spec to cope with icons and desktop file 418 | - Improve cluster file import efficiency as was taking faaar too long previously 419 | - Fixed bug whereby when pid's of the xterm changes records were not updated 420 | - Do not die when pipe open fails, but continue as others may be connected 421 | - Remove code that breaks the minimize/maximise stuff; 422 | - Catch X button presses on title bar to close all windows correctly 423 | - Delay map event capture at program start to avoid infinite loop 424 | - Fix execvp error on Solaris 10 425 | 426 | 3.18.1_1 2005-11-28 Duncan Ferguson 427 | 428 | - Correct mask value for backtick (grave) character 429 | - Add more logging for debug mode 430 | - Amend indentation 431 | - Rerun through perltidy 432 | - Improve cluster file import efficiency as was taking faaar too long previously 433 | - Fixed bug whereby when pid's of the xterm changes records were not updated 434 | - Do not die when pipe open fails, but continue as others may be connected 435 | - Remove code that breaks the minimize/maximise stuff; 436 | - Catch X button presses on title bar to close all windows correctly 437 | - Delay map event capture at program start to avoid infinite loop 438 | - Fix execvp error on Solaris 10 439 | - Update to man pages 440 | 441 | 3.17.1 2005-06-24 Duncan Ferguson 442 | 443 | - Allow _'s in paste text correctly 444 | - Bugfix minimise/maximise again 445 | - Run through "perltidy -i=4 -ce" 446 | - Unmap all windows in one go instead of one at a time when retiling 447 | - Add + doc 'console_position' 448 | - Maintain user position of console between maps (i.e. tell window manager 449 | not to move it) 450 | - Note that ssh options are for OpenSSH not for any other ssh version 451 | 452 | 3.16.1 2005-06-13 Duncan Ferguson 453 | 454 | - Allow ignoring of unresolved hosts (i.e. if hostname aliased in 455 | ssh config file) 456 | 457 | 3.15.1 2005-06-09 Duncan Ferguson 458 | 459 | - Add and document "-c " 460 | - Add and document "-l " 461 | - Add and document "-o " 462 | - Document "-t " 463 | - Set controlled terminals to have user set size & position (WM_SIZE_HINTS) 464 | - Speed up initial terminal openings 465 | - Remove all key bindings from drop down menus (conflicts with emacs and 466 | can all be done by other hotkeys anyhow) 467 | - Allow individual hotkeys to be disabled, instead of all-or-nothing 468 | - Updates to POD 469 | - Update retile code to avoid flickering windows (& also fix cygwin bug) 470 | - Rename -t to -T to match previous series option 471 | - Added in -t to modify cmd line args for terminals 472 | 473 | 3.14.1 2005-06-04 Duncan Ferguson <duncan_ferguson@user.sf.net> 474 | 475 | - first cut at terminal opening speed up 476 | 477 | 3.13.1 2005-05-20 Duncan Ferguson <duncan_ferguson@user.sf.net> 478 | 479 | - Bugfix for whitespace in config files (missing a char from regexp) 480 | - Allow for minimising/maximising all windows when done on console 481 | 482 | 3.12.1 2005-05-19 Duncan Ferguson <duncan_ferguson@user.sf.net> 483 | 484 | - Bugfix for shifted non-alphanumeric keyboard chars not being pasted correctly 485 | - Marked version number with 3rd digit to signify beta releases 486 | 487 | 3.11 2005-05-18 Duncan Ferguson <duncan_ferguson@user.sf.net> 488 | 489 | - Remove trailing whitespace from config file lines 490 | - Prevent paste events being sent to non-active clients 491 | - Allow paste events to send capitalised letters 492 | 493 | 3.10 2005-05-17 Duncan Ferguson <duncan_ferguson@user.sf.net> 494 | 495 | - fix for moving atom numbers in font info 496 | 497 | 3.9 2005-05-11 Duncan Ferguson <duncan_ferguson@user.sf.net> 498 | 499 | - Allow multiple hosts or tags in the "Add Host" text widget 500 | - Retile all windows (if set) after adding a host 501 | - Do not automatically send a return after hostname (Alt-n) 502 | - Fix bug with sending read hostname instead of internal unique host 503 | name (Alt-n) 504 | - Fix bug whereby cannot start cssh without any hosts on cmd-line 505 | - Fix bug where client name was sent to inactive clients 506 | - Fix bug whereby 0's in sent text were ignored 507 | 508 | 3.8 2005-05-09 Duncan Ferguson <duncan_ferguson@user.sf.net> 509 | 510 | - Remove the need for xlsfonts (perform function by X window calls instead) 511 | - Debug level output changes 512 | - Ensure windows are overlapping in the right places, instead of any order 513 | - Create config section on window decorations (i.e. title & scroll bars) 514 | 515 | 3.7 2005-05-05 Duncan Ferguson <duncan_ferguson@user.sf.net> 516 | 517 | - Found ConfigureWindow instead of ResizeMoveWindow 518 | 519 | 3.6 2005-05-05 Duncan Ferguson <duncan_ferguson@user.sf.net> 520 | 521 | - Lots of work on window tiling - to fall at last hurdle (No XResizeMoveWindow) 522 | - Documentation updates 523 | - Allow -u ouput when binaries havnt been found 524 | - Start coding for capturing an existing terminal window 525 | - Rebuild hosts menu when all hosts checked, not when each host checked 526 | - Change debug message output level of keysyms 527 | - Cater for config of no tiling, but allow to retile in console window anyhow 528 | 529 | 3.5 2005-05-03 Duncan Ferguson <duncan_ferguson@user.sf.net> 530 | 531 | - Remove some old (commented out) code 532 | - Remove some (unnecessary) debug code 533 | - Start coding for window tiling 534 | - Modify find_binary function to make it more portable 535 | - Output internal vars in "-u -d" 536 | - Small mods to docs to take account of all of the above 537 | 538 | 3.4 2005-04-26 Duncan Ferguson <duncan_ferguson@user.sf.net> 539 | 540 | - Changed order of "use POSIX" to put :sys_wait_h first to avoid chance of 541 | hitting known issue 542 | - Allow for running from cvs dir in config{comms} 543 | - Add "ConnectTimeout=10" to default ssh options 544 | - Add further debug info 545 | - Add check to ensure hostname can be resolved before attempting connection 546 | - Modigy zombie reaping to prevent hand on unconnected cx term closing 547 | - Add "autoquit" feature to close ClusterSSH after last client window closes 548 | - Also produce man page and include as part of install 549 | 550 | 3.3 2005-04-10 Duncan Ferguson <duncan_ferguson@user.sf.net> 551 | 552 | - src/cssh.pl: Rewritten from scratch 553 | - Set up to use Gnu Autotools 554 | -------------------------------------------------------------------------------- /THANKS: -------------------------------------------------------------------------------- 1 | ClusterSSH THANKS file 2 | 3 | ClusterSSH has originally been written by Duncan Ferguson. Many 4 | people further contributed to ClusterSSH by reporting problems, 5 | suggesting various improvements or submitting actual code. 6 | Here is a list of these people. Help me keep it complete and 7 | exempt of errors. 8 | 9 | Tony Mancill 10 | David Gardner 11 | Hans-Joachim Hoetger 12 | Gavin Brock 13 | Bren Viren 14 | Rob Petty 15 | Jason (jklap) 16 | Cyril Bouthors 17 | Chris Trahman 18 | Olivier Beyssac 19 | Rob Dawson 20 | Steve Roome 21 | D. Dumont 22 | Dan Wallis 23 | Jima 24 | Harald Weidner 25 | Klaus Ethgen 26 | Nicolas Simonds 27 | Peter Palfrader 28 | David F. Skoll 29 | Bogdan Pintea 30 | Gerfried Fuchs 31 | Stanislas Rouvelin 32 | Sami Kerola 33 | Kristian Lyngstol 34 | Mike Loseke 35 | Ian Marsh 36 | Roland Rosenfeld 37 | Wei Wang 38 | Markus Manzke 39 | Simon Fraser 40 | Stefan Steiner 41 | Ryan Brown 42 | Brandon Perkins 43 | Oliver Meissner 44 | Andrew Stevenson (cqexbesd) 45 | Emanuele Tomasi 46 | Deny Dias 47 | Bill Rushmore 48 | Ankit Vadehra 49 | Azenet 50 | Markus Frosch (lazyfrosch) 51 | Petr Vorel 52 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Overview of tasks 2 | ================= 3 | 4 | Change way terminal windows are created 5 | ======================================= 6 | 7 | Set up terminal windows in Tk to embed termainal session into it, such 8 | as with xterm: 9 | 10 | xterm -wid <wid> .... 11 | 12 | This may limit what terminals can be used, though 13 | 14 | See also: 15 | http://www.perlmonks.org/?node_id=359764 16 | http://www.perlmonks.org/?node_id=643221 17 | -------------------------------------------------------------------------------- /bin_PL/_build_docs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.008.004; 3 | use strict; 4 | use warnings; 5 | 6 | use FindBin qw($Bin $Script); 7 | use File::Basename; 8 | 9 | my $bindir = "bin"; 10 | 11 | if ( !-d $bindir ) { 12 | mkdir $bindir || die "Could not mkdir $bindir: $!"; 13 | } 14 | 15 | print "Using perl binary: $^X", $/; 16 | print "Using perl version $^V", $/; 17 | 18 | for my $dest (@ARGV) { 19 | my $source = $Bin . '/' . basename($dest); 20 | 21 | next if ( $source =~ m/$Script/ ); 22 | next if ( $source =~ m/\.x$/ ); 23 | 24 | print "Generating: $source", $/; 25 | 26 | if ( -f $dest ) { 27 | chmod( 0755, $dest ) || die "Could not chmod $dest for removing: $!"; 28 | } 29 | 30 | open( my $sfh, '<', $source ) 31 | || die "Could not open $source for reading: $!"; 32 | open( my $dfh, '>', $dest ) || die "Could not open $dest for writing: $!"; 33 | print $dfh $_ while (<$sfh>); 34 | close($sfh); 35 | 36 | if ( $source !~ m/clusterssh_bash_completion.dist/ ) { 37 | print $dfh "\n\n__END__\n\n"; 38 | 39 | my $pod = qx{ $^X $source --generate-pod }; 40 | die "Failed to generate pod" if ($?); 41 | print $dfh $pod; 42 | } 43 | 44 | close($dfh); 45 | 46 | chmod( 0555, $dest ) || die "Could not chmod $dest: $!"; 47 | } 48 | -------------------------------------------------------------------------------- /bin_PL/ccon: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.008.004; 3 | use strict; 4 | use warnings; 5 | 6 | use FindBin; 7 | use lib $FindBin::Bin. '/../lib'; 8 | use lib $FindBin::Bin. '/../lib/perl5'; 9 | use App::ClusterSSH; 10 | 11 | my $app = App::ClusterSSH->new(); 12 | 13 | #$app->options->add_common_ssh_options; 14 | #$app->options->add_common_session_options; 15 | 16 | $app->add_option( 17 | spec => 'master|M=s', 18 | help => $app->loc( 19 | "The console client program polls master as the primary server, rather than the default set at compile time (typically ``console'')." 20 | ), 21 | ); 22 | 23 | $app->run(); 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /bin_PL/clusterssh_bash_completion.dist: -------------------------------------------------------------------------------- 1 | # -*- mode: shell-script; sh-basic-offset: 8; indent-tabs-mode: t -*- 2 | # ex: ts=8 sw=8 noet filetype=sh 3 | # 4 | # cssh(1) completion by Aaron Spettl <aaron@spettl.de>, adapted from the 5 | # Debian GNU/Linux dput(1) completion by Roland Mas <lolando@debian.org> 6 | # 7 | # On Debian (and Debian based distributions) drop this file into 8 | # /etc/bash_completion.d 9 | # and source the /etc/bash_completion script - or just restart bash. 10 | 11 | _cssh () 12 | { 13 | local cur prev options paroptions clusters extra_cluster_file_line clusters_line extra_cluster_file 14 | 15 | COMPREPLY=() 16 | cur=${COMP_WORDS[COMP_CWORD]} 17 | prev=${COMP_WORDS[COMP_CWORD-1]} 18 | 19 | # all options understood by cssh 20 | options='-c --cluster-file -C --config-file --debug -e --evaluate \ 21 | -g --tile -G --no-tile -h --help -H --man -l --username \ 22 | -o --options -p --port -q --autoquit -Q --no-autoquit \ 23 | -s --show-history -t --term-args -T --title \ 24 | -u --output-config -v --version' 25 | 26 | # find the extra cluster file line in the .clusterssh/config or, alternatively, /etc/csshrc 27 | extra_cluster_file_line="`grep '^[[:space:]]*extra_cluster_file' $HOME/.clusterssh/config 2> /dev/null`" 28 | [ -z "$extra_cluster_file_line" ] && extra_cluster_file_line="`grep '^[[:space:]]*extra_cluster_file' /etc/csshrc 2> /dev/null`" 29 | 30 | # find the clusters line in the .csshrc or, alternatively, /etc/csshrc 31 | clusters_line="`grep '^[[:space:]]*clusters' $HOME/.clusterssh/config 2> /dev/null`" 32 | [ -z "$clusters_line" ] && clusters_line="`grep '^[[:space:]]*clusters' /etc/csshrc 2> /dev/null`" 33 | 34 | # extract the location of the extra cluster file 35 | extra_cluster_file="`echo $extra_cluster_file_line | cut -f 2- -d '='`" 36 | [ -n "$extra_cluster_file" ] && extra_cluster_file="`eval echo $extra_cluster_file`" 37 | # TODO: don't use eval to expand ~ and $HOME 38 | 39 | # get the names of all defined clusters 40 | clusters=$( 41 | { 42 | [ -n "$clusters_line" ] && echo "$clusters_line" | cut -f 2- -d '=' | tr "$IFS" "\n" || /bin/true 43 | [ -n "$extra_cluster_file" ] && sed -e 's/^\([a-z0-9.-]\+\).*$/\1/i' "$extra_cluster_file" 2> /dev/null || /bin/true 44 | sed -e 's/^\([a-z0-9.-]\+\).*$/\1/i' /etc/clusters 2> /dev/null || /bin/true 45 | sed -e 's/^\([a-z0-9.-]\+\).*$/\1/i' $HOME/.clusterssh/clusters 2> /dev/null || /bin/true 46 | } | sort -u) 47 | 48 | # use options and clusters for tab completion, except there isn't yet 49 | # at least one character to filter by 50 | # reason: don't show options if the user types "cssh <tab><tab>" 51 | paroptions="$clusters" 52 | [ -n "$cur" ] && paroptions="$paroptions $options" 53 | 54 | case $prev in 55 | --cluster-file|-c|--config-file|-C) 56 | COMPREPLY=( $( compgen -o filenames -G "$cur*" ) ) 57 | ;; 58 | *) 59 | COMPREPLY=() 60 | 61 | # also use ssh hosts for tab completion if function _known_hosts is present 62 | [ "`type -t _known_hosts`" = "function" ] && _known_hosts -a 63 | 64 | COMPREPLY=( "${COMPREPLY[@]}" $( compgen -W "$paroptions" | grep "^$cur") ) 65 | ;; 66 | esac 67 | 68 | return 0 69 | } && 70 | complete -F _cssh cssh crsh ctel 71 | -------------------------------------------------------------------------------- /bin_PL/crsh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.008.004; 3 | use strict; 4 | use warnings; 5 | 6 | use FindBin; 7 | use lib $FindBin::Bin. '/../lib'; 8 | use lib $FindBin::Bin. '/../lib/perl5'; 9 | use App::ClusterSSH; 10 | 11 | my $app = App::ClusterSSH->new(); 12 | 13 | $app->options->add_common_ssh_options; 14 | $app->options->add_common_session_options; 15 | $app->run(); 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /bin_PL/cscp.x: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | #LICENSE: GNU GPL version 2 4 | #Author: JT Moree: moreejt@pcxperience.com 5 | #Copyright: Kahala Corp. 2006 6 | #Date: 20061213 7 | # 8 | # $URL$ 9 | # $Id$ 10 | # 11 | 12 | VERSION='$Revision$ ($Date$)' 13 | PROGRAM=`basename $0` 14 | DEBUG=n 15 | ETC=/etc/clusterscp 16 | CONF=/etc/clusters 17 | RC=/etc/clusterscprc 18 | GRP= 19 | COMMENT= 20 | DEST= 21 | SYSLOG=0 22 | 23 | usage() 24 | { 25 | cat <<FOO 26 | 27 | $PROGRAM v. $VERSION 28 | Usage: $PROGRAM [options] -C<cluster> file1 file2 file3 . . . 29 | or $PROGRAM [options] -H<user@host> file1 file2 file3 . . . 30 | 31 | This program copies files to multiple remote machines using ssh and scp and can log the action. 32 | 33 | LICENSE 34 | Released under the terms of the GNU GPL version 2 35 | 36 | OPTIONS 37 | -C server cluster(s) to scp to. see GROUPS/CLUSTERS 38 | -D destination directory on target servers 39 | -d Debug mode 40 | -H scp to this one host (format user@host) 41 | -h help 42 | -f Use this config file for groups/clusters. Use this to override the use of clusterssh config in /etc/clusters. 43 | -t comment to describe the action 44 | 45 | Make sure to use quotes when there are spaces in your params. 46 | 47 | GROUPS/CLUSTERS 48 | 49 | This script uses scp to copy files to the specified destination of each server 50 | in a server cluster. A server cluster is specified in a file (usually $CONF) 51 | in the format: 52 | <clustername> <user>@<server> <user>@<server> . . . . 53 | See clusterssh for more info 54 | 55 | Each cluster may also have custom configurations specified in a file ending with .cfg. 56 | ie. servers A, B, and C are in group FOO. There is a line in file $CONF 57 | FOO root@A root@B root@C 58 | and potentially another file $ETC/FOO.cfg 59 | 60 | CONFIG FILES 61 | 62 | In the .cfg file vars can be set in the form of bash/sh vars: 63 | LOG=/root/Documentation/changelog 64 | 65 | LOGGING to SYSLOG 66 | 67 | The log string will use the format 68 | 20060111 11:11:11 user clusterscp:cluster:comment: <files> 69 | The script attempts to use logger (syslog) on each target machine. To turn 70 | this off set the SYSLOG=0 config in $RC or in the .cfg for that cluster. 71 | 72 | LOGGING to a CUSTOM LOG 73 | 74 | The log string will use the format 75 | 20060111 11:11:11 user clusterscp:group:comment: <files> 76 | The .cfg file can have a parameter set LOG=/path/to/log. If so, it logs the 77 | action to that file by appending to the end of it. 78 | 79 | SSH w/o PASSWORDS 80 | 81 | If ssh public/private key authentication is setup with no passphrase then no password is neccessary to scp the files. Otherwise you will be prompted for each server password. 82 | 83 | FOO 84 | } 85 | 86 | copy_files() 87 | { 88 | copy_files_TARGET=$1 89 | copy_files_DEST=$2 90 | shift 2 91 | CHECK=`echo $copy_files_TARGET | grep '@'` 92 | if [ -z "$CHECK" ] ; then #target does not have format of user@host. perhaps it is another cluster? 93 | #check to see if a cluster matches this name and process it 94 | copy_cluster "$copy_files_TARGET" "$copy_files_DEST" $@ 95 | else 96 | if [ "$DEBUG" = "y" ] ; then 97 | echo scp $@ $copy_files_TARGET:$copy_files_DEST >/dev/null 98 | else 99 | scp $@ $copy_files_TARGET:$copy_files_DEST >/dev/null 100 | fi 101 | if [ "$?" -eq 0 ] ; then 102 | echo "$copy_files_TARGET: OK" 103 | 104 | if [ $SYSLOG -eq 1 ] ; then 105 | if [ "$DEBUG" = "y" ] ; then 106 | echo ssh $copy_files_TARGET "logger -t$PROGRAM -pauth.info '$LOGSTRING'" 107 | else 108 | ssh $copy_files_TARGET "logger -t$PROGRAM -pauth.info '$LOGSTRING'" 109 | fi 110 | fi 111 | if [ -n "$LOG" ] ; then 112 | if [ "$DEBUG" = "y" ] ; then 113 | echo ssh $copy_files_TARGET "echo '`date +"%Y%m%d %H:%M:%S"` $LOGSTRING' >> $LOG" 114 | else 115 | ssh $copy_files_TARGET "echo '`date +"%Y%m%d %H:%M:%S"` $LOGSTRING' >> $LOG" 116 | fi 117 | fi 118 | else 119 | echo "$copy_files_TARGET: ERROR" 120 | fi 121 | fi 122 | } 123 | 124 | copy_cluster() 125 | { 126 | copy_cluster_CLUSTER=$1 127 | copy_cluster_DEST=$2 128 | shift 2 129 | copy_cluster_SKIP= #to skip the first word in the line 130 | copy_cluster_COUNT=0 131 | for copy_cluster_TARGET in `egrep "^$copy_cluster_CLUSTER" $CONF` ; do 132 | if [ -z "$copy_cluster_SKIP" ] ; then 133 | copy_cluster_SKIP=n 134 | else 135 | copy_files "$copy_cluster_TARGET" "$copy_cluster_DEST" $@ 136 | fi 137 | copy_cluster_COUNT=$(($copy_cluster_COUNT + 1)) 138 | done 139 | if [ 0 -eq $copy_cluster_COUNT ] ; then 140 | echo "Warning! No cluster found with name $copy_cluster_CLUSTER" >&2 141 | fi 142 | } 143 | 144 | #source global config file 145 | if [ -f $RC ] ; then 146 | . $RC 147 | fi 148 | 149 | while getopts C:dD:f:hH:t:vx OPTION 150 | do 151 | case "$OPTION" in 152 | h) usage ; exit 1 153 | ;; 154 | v) echo $VERSION; exit 1 155 | ;; 156 | x) set -x; DEBUG=y; shift 1 157 | ;; 158 | C) GRP=$OPTARG; shift 2 159 | ;; 160 | d) DEBUG=y; shift 1 161 | ;; 162 | D) DEST=$OPTARG; shift 2 163 | ;; 164 | f) CONF=$OPTARG; shift 2 165 | ;; 166 | H) HOST=$OPTARG; shift 2 167 | ;; 168 | t) COMMENT=$OPTARG; shift 2 169 | ;; 170 | *) echo ; echo "!!!!!!Error. Invalid option given" >&2; echo ; usage; exit 1 171 | ;; 172 | esac 173 | done 174 | 175 | if [ -z "$GRP" ] && [ -z "$HOST" ] ; then 176 | usage 177 | echo 178 | echo "Error. You must specify a cluster or a host (-C or -H)!" >&2 179 | exit 1 180 | fi 181 | 182 | #do a sanity check on all files 183 | if [ 0 -eq $# ] ; then 184 | usage 185 | echo "Error. No files specified." >&2 186 | exit 1 187 | fi 188 | for f in $@ ; do 189 | if [ ! -r $f ] ; then 190 | echo "Error reading file $f. Aborting transaction." >&2 191 | exit 1 192 | fi 193 | #build file list for log 194 | FILES="${FILES} `basename $f`" 195 | done 196 | 197 | if [ -n "$HOST" ] ; then 198 | CHECK=`echo $HOST | grep '@'` 199 | if [ -z "$CHECK" ] ; then #target does not have format of user@host. perhaps it is another cluster? 200 | echo "Error! -H option must use format user@host: '$HOST' is invalid." >&2 201 | echo "If this is a cluster use the -C option." >&2 202 | exit 1 203 | fi 204 | #build log string 205 | LOGSTRING="$USER $PROGRAM:$COMMENT:$DEST $FILES" 206 | copy_files "$HOST" "$DEST" $@ 207 | fi 208 | 209 | if [ -n "$GRP" ] ; then 210 | #build log string 211 | LOGSTRING="$USER $PROGRAM $GRP:$COMMENT:$DEST $FILES" 212 | if [ -r $ETC/$GRP.cfg ] ; then 213 | . $ETC/$GRP.cfg 214 | fi 215 | if [ -z "$SYSLOG" ] ; then 216 | SYSLOG=0 217 | fi 218 | 219 | if [ "$DEBUG" = "y" ] ; then 220 | echo "cluster IS '$GRP'" 221 | fi 222 | 223 | copy_cluster "$GRP" "$DEST" $@ 224 | fi 225 | -------------------------------------------------------------------------------- /bin_PL/csftp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.008.004; 3 | use strict; 4 | use warnings; 5 | 6 | use FindBin; 7 | use lib $FindBin::Bin. '/../lib'; 8 | use lib $FindBin::Bin. '/../lib/perl5'; 9 | use App::ClusterSSH; 10 | 11 | my $app = App::ClusterSSH->new(); 12 | 13 | $app->options->add_common_ssh_options; 14 | $app->options->add_common_session_options; 15 | $app->run(); 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /bin_PL/cssh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.008.004; 3 | use strict; 4 | use warnings; 5 | 6 | use FindBin; 7 | use lib $FindBin::Bin. '/../lib'; 8 | use lib $FindBin::Bin. '/../lib/perl5'; 9 | use App::ClusterSSH; 10 | 11 | my $app = App::ClusterSSH->new(); 12 | 13 | $app->options->add_common_ssh_options; 14 | $app->options->add_common_session_options; 15 | $app->run(); 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /bin_PL/ctel: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.008.004; 3 | use strict; 4 | use warnings; 5 | 6 | use FindBin; 7 | use lib $FindBin::Bin. '/../lib'; 8 | use lib $FindBin::Bin. '/../lib/perl5'; 9 | use App::ClusterSSH; 10 | 11 | my $app = App::ClusterSSH->new(); 12 | 13 | $app->run(); 14 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = App-ClusterSSH 2 | author = Duncan Ferguson <duncan_j_ferguson@yahoo.co.uk> 3 | license = Perl_5 4 | copyright_holder = Duncan Ferguson 5 | copyright_year = 2018 6 | 7 | [Git::Check] 8 | 9 | [GatherDir] 10 | [MetaYAML] 11 | [ModuleBuild::Custom] 12 | mb_class = App::ClusterSSH:Build 13 | 14 | [InstallGuide] 15 | [License] 16 | [PruneCruft] 17 | [PruneFiles] 18 | match = ^bin/ 19 | match = \.bak$ 20 | match = ^Build\.PL\. 21 | 22 | [ManifestSkip] 23 | [Manifest] 24 | [TestRelease] 25 | [ConfirmRelease] 26 | [UploadToCPAN] 27 | 28 | ; for later 29 | ;[Twitter] 30 | [EmailNotify] 31 | to = duncan_j_ferguson@yahoo.co.uk 32 | from = duncan_j_ferguson@yahoo.co.uk 33 | 34 | [CheckChangeLog] 35 | 36 | [PerlTidy] 37 | perltidyrc = t/perltidyrc 38 | 39 | ; Need to decide how to do this automatically at some point 40 | [VersionFromModule] 41 | ;[Git::NextVersion] 42 | ;[AutoVersion] 43 | [AutoPrereqs] 44 | [PkgVersion] 45 | [NextRelease] 46 | [Git::Commit] 47 | [Git::Tag] 48 | [Git::Push] 49 | 50 | ; optional prereqs - only used if they are installed 51 | [Prereqs / RuntimeRecommends] 52 | Sort::Naturally = 1.03 53 | 54 | ; Author prereqs 55 | ; authordep Pod::Coverage::TrustPod 56 | ; authordep Test::CPAN::Changes 57 | 58 | [MetaResources] 59 | homepage = http://github.com/duncs/clusterssh/wiki 60 | bugtracker.web = https://github.com/duncs/clusterssh/issues 61 | repository.web = http://github.com/duncs/clusterssh 62 | repository.type = git 63 | ; these two custom ones cause errors 64 | ;Ci.web = https://travis-ci.org/duncs/clusterssh 65 | ;Coverage.web = https://coveralls.io/github/duncs/clusterssh 66 | 67 | [ExtraTests] 68 | ; Disabled for the moment 69 | ;[Test::Perl::Critic] 70 | [PodCoverageTests] 71 | [PodSyntaxTests] 72 | 73 | [Run::BeforeBuild] 74 | run = bin_PL/cssh --generate-pod | pod2text > README 75 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH.pm: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | package App::ClusterSSH; 5 | 6 | # ABSTRACT: Cluster administration tool 7 | # ABSTRACT: Cluster administration tool 8 | 9 | use version; our $VERSION = version->new('4.18'); 10 | 11 | =head1 SYNOPSIS 12 | 13 | There is nothing in this module for public consumption. See documentation 14 | for F<cssh>, F<crsh>, F<ctel>, F<ccon>, or F<cscp> instead. 15 | 16 | =head1 DESCRIPTION 17 | 18 | This is the core for App::ClusterSSH. You should probably look at L<cssh> 19 | instead. 20 | 21 | =head1 SUBROUTINES/METHODS 22 | 23 | These methods are listed here to tidy up Pod::Coverage test reports but 24 | will most likely be moved into other modules. There are some notes within 25 | the code until this time. 26 | 27 | =over 2 28 | 29 | =cut 30 | 31 | use Carp qw/cluck :DEFAULT/; 32 | 33 | use base qw/ App::ClusterSSH::Base /; 34 | use App::ClusterSSH::Host; 35 | use App::ClusterSSH::Config; 36 | use App::ClusterSSH::Helper; 37 | use App::ClusterSSH::Cluster; 38 | use App::ClusterSSH::Getopt; 39 | use App::ClusterSSH::Window; 40 | 41 | use FindBin qw($Script); 42 | 43 | use POSIX ":sys_wait_h"; 44 | use POSIX qw/:sys_wait_h strftime mkfifo/; 45 | use File::Temp qw/:POSIX/; 46 | use Fcntl; 47 | use File::Basename; 48 | use Net::hostent; 49 | use Sys::Hostname; 50 | use English; 51 | use Socket; 52 | use File::Path qw(make_path); 53 | 54 | # Notes on general order of processing 55 | # 56 | # parse cmd line options for extra config files 57 | # load system configuration files 58 | # load cfg files from options 59 | # overlay rest of cmd line args onto options 60 | # record all clusters 61 | # parse given tags/hostnames and resolve to connections 62 | # open terminals 63 | # optionally open console if required 64 | 65 | sub new { 66 | my ( $class, %args ) = @_; 67 | 68 | my $self = $class->SUPER::new(%args); 69 | 70 | $self->{cluster} = App::ClusterSSH::Cluster->new( parent => $self, ); 71 | $self->{options} = App::ClusterSSH::Getopt->new( parent => $self, ); 72 | $self->{config} = App::ClusterSSH::Config->new( parent => $self, ); 73 | $self->{helper} = App::ClusterSSH::Helper->new( parent => $self, ); 74 | $self->{window} = App::ClusterSSH::Window->new( parent => $self, ); 75 | 76 | $self->set_config( $self->config ); 77 | 78 | # catch and reap any zombies 79 | $SIG{CHLD} = sub { 80 | my $kid; 81 | do { 82 | $kid = waitpid( -1, WNOHANG ); 83 | $self->debug( 2, "REAPER currently returns: $kid" ); 84 | } until ( $kid == -1 || $kid == 0 ); 85 | }; 86 | 87 | return $self; 88 | } 89 | 90 | sub config { 91 | my ($self) = @_; 92 | return $self->{config}; 93 | } 94 | 95 | sub cluster { 96 | my ($self) = @_; 97 | return $self->{cluster}; 98 | } 99 | 100 | sub helper { 101 | my ($self) = @_; 102 | return $self->{helper}; 103 | } 104 | 105 | sub options { 106 | my ($self) = @_; 107 | return $self->{options}; 108 | } 109 | 110 | sub getopts { 111 | my ($self) = @_; 112 | return $self->options->getopts; 113 | } 114 | 115 | sub add_option { 116 | my ( $self, %args ) = @_; 117 | return $self->{options}->add_option(%args); 118 | } 119 | 120 | sub window { 121 | my ($self) = @_; 122 | return $self->{window}; 123 | } 124 | 125 | # Set up UTF-8 on STDOUT 126 | binmode STDOUT, ":utf8"; 127 | 128 | #use bytes; 129 | 130 | ### all sub-routines ### 131 | 132 | # catch_all exit routine that should always be used 133 | sub exit_prog() { 134 | my ($self) = @_; 135 | $self->debug( 3, "Exiting via normal routine" ); 136 | 137 | if ( $self->config->{external_command_pipe} 138 | && -e $self->config->{external_command_pipe} ) 139 | { 140 | close( $self->{external_command_pipe_fh} ) 141 | or warn( 142 | "Could not close pipe " 143 | . $self->config->{external_command_pipe} . ": ", 144 | $! 145 | ); 146 | $self->debug( 2, "Removing external command pipe" ); 147 | unlink( $self->config->{external_command_pipe} ) 148 | || warn "Could not unlink " 149 | . $self->config->{external_command_pipe} 150 | . ": ", $!; 151 | } 152 | 153 | $self->window->terminate_all_hosts; 154 | 155 | exit 0; 156 | } 157 | 158 | sub evaluate_commands { 159 | my ($self) = @_; 160 | my ( $return, $user, $port, $host ); 161 | 162 | # break apart the given host string to check for user or port configs 163 | my $evaluate = $self->options->evaluate; 164 | print "{evaluate}=", $evaluate, "\n"; 165 | $user = $1 if ( ${evaluate} =~ s/^(.*)@// ); 166 | $port = $1 if ( ${evaluate} =~ s/:(\w+)$// ); 167 | $host = ${evaluate}; 168 | 169 | $user = $user ? "-l $user" : ""; 170 | if ( $self->config->{comms} eq "telnet" ) { 171 | $port = $port ? " $port" : ""; 172 | } 173 | else { 174 | $port = $port ? "-p $port" : ""; 175 | } 176 | 177 | print STDERR "Testing terminal - running command:\n"; 178 | 179 | my $command = "$^X -e 'print \"Base terminal test\n\"; sleep 2'"; 180 | 181 | my $terminal_command = join( ' ', 182 | $self->config->{terminal}, 183 | $self->config->{terminal_allow_send_events}, "-e " ); 184 | 185 | my $run_command = "$terminal_command $command"; 186 | 187 | print STDERR $run_command, $/; 188 | 189 | system($run_command); 190 | print STDERR "\nTesting comms - running command:\n"; 191 | 192 | my $comms_command = join( ' ', 193 | $self->config->{ $self->config->{comms} }, 194 | $self->config->{ $self->config->{comms} . "_args" } ); 195 | 196 | if ( $self->config->{comms} eq "telnet" ) { 197 | $comms_command .= " $host $port"; 198 | } 199 | else { 200 | $comms_command 201 | .= " $user $port $host hostname ; echo Got hostname via ssh; sleep 2"; 202 | } 203 | 204 | print STDERR $comms_command, $/; 205 | 206 | system($comms_command); 207 | 208 | $run_command = "$terminal_command '$comms_command'"; 209 | print STDERR $run_command, $/; 210 | 211 | system($run_command); 212 | 213 | $self->exit_prog; 214 | } 215 | 216 | sub resolve_names(@) { 217 | my ( $self, @servers ) = @_; 218 | $self->debug( 2, 'Resolving cluster names: started' ); 219 | 220 | foreach (@servers) { 221 | my $dirty = $_; 222 | my $username = q{}; 223 | $self->debug( 3, 'Checking tag ', $_ ); 224 | 225 | if ( $dirty =~ s/^(.*)@// ) { 226 | $username = $1; 227 | } 228 | 229 | my @tag_list = $self->cluster->get_tag($dirty); 230 | 231 | if ( $self->config->{use_all_a_records} 232 | && $dirty !~ m/^(\d{1,3}\.?){4}$/ 233 | && !@tag_list ) 234 | { 235 | my $hostobj = gethostbyname($dirty); 236 | if ( defined($hostobj) ) { 237 | my @alladdrs = map { inet_ntoa($_) } @{ $hostobj->addr_list }; 238 | $self->cluster->register_tag( $dirty, @alladdrs ); 239 | if ( $#alladdrs > 0 ) { 240 | $self->debug( 3, 'Expanded to ', 241 | join( ' ', $self->cluster->get_tag($dirty) ) ); 242 | @tag_list = $self->cluster->get_tag($dirty); 243 | } 244 | else { 245 | # don't expand if there is only one record found 246 | $self->debug( 3, 'Only one A record' ); 247 | } 248 | } 249 | } 250 | if (@tag_list) { 251 | $self->debug( 3, '... it is a cluster' ); 252 | foreach my $node (@tag_list) { 253 | if ($username) { 254 | $node =~ s/^(.*)@//; 255 | $node = $username . '@' . $node; 256 | } 257 | push( @servers, $node ); 258 | } 259 | $_ = q{}; 260 | } 261 | } 262 | 263 | # now run everything through the external command, if one is defined 264 | if ( $self->config->{external_cluster_command} ) { 265 | $self->debug( 4, 'External cluster command defined' ); 266 | 267 | # use a second array here in case of failure so previously worked 268 | # out entries are not lost 269 | my @new_servers; 270 | eval { 271 | @new_servers = $self->cluster->get_external_clusters(@servers); 272 | }; 273 | 274 | if ($@) { 275 | warn $@, $/; 276 | } 277 | else { 278 | @servers = @new_servers; 279 | } 280 | } 281 | 282 | # now clean the array up 283 | @servers = grep { $_ !~ m/^$/ } @servers; 284 | 285 | if ( $self->config->{unique_servers} ) { 286 | $self->debug( 3, 'removing duplicate server names' ); 287 | @servers = $self->remove_repeated_servers(@servers); 288 | } 289 | 290 | $self->debug( 3, 'leaving with ', $_ ) foreach (@servers); 291 | $self->debug( 2, 'Resolving cluster names: completed' ); 292 | return (@servers); 293 | } 294 | 295 | sub remove_repeated_servers { 296 | my $self = shift; 297 | my %all = (); 298 | @all{@_} = 1; 299 | return ( keys %all ); 300 | } 301 | 302 | sub run { 303 | my ($self) = @_; 304 | 305 | $self->getopts; 306 | 307 | ### main ### 308 | 309 | $self->window->initialise; 310 | 311 | $self->debug( 2, "VERSION: ", $__PACKAGE__::VERSION ); 312 | 313 | # only use ssh_args from options if config file ssh_args not set AND 314 | # options is not the default value otherwise the default options 315 | # value is used instead of the config file 316 | if ( $self->config->{comms} eq 'ssh' ) { 317 | if ( defined $self->config->{ssh_args} ) { 318 | if ( $self->options->options 319 | && $self->options->options ne 320 | $self->options->options_default ) 321 | { 322 | $self->config->{ssh_args} = $self->options->options; 323 | } 324 | } 325 | else { 326 | $self->config->{ssh_args} = $self->options->options 327 | if ( $self->options->options ); 328 | } 329 | } 330 | 331 | $self->config->{terminal_args} = $self->options->term_args 332 | if ( $self->options->term_args ); 333 | 334 | if ( $self->config->{terminal_args} =~ /-class (\w+)/ ) { 335 | $self->config->{terminal_allow_send_events} 336 | = "-xrm '$1.VT100.allowSendEvents:true'"; 337 | } 338 | 339 | $self->config->dump() if ( $self->options->dump_config ); 340 | 341 | $self->evaluate_commands() if ( $self->options->evaluate ); 342 | 343 | $self->window->get_font_size(); 344 | 345 | $self->window->load_keyboard_map(); 346 | 347 | # read in normal cluster files 348 | $self->config->{extra_cluster_file} .= ',' . $self->options->cluster_file 349 | if ( $self->options->cluster_file ); 350 | $self->config->{extra_tag_file} .= ',' . $self->options->tag_file 351 | if ( $self->options->tag_file ); 352 | 353 | $self->cluster->get_cluster_entries( split /,/, 354 | $self->config->{extra_cluster_file} || '' ); 355 | $self->cluster->get_tag_entries( split /,/, 356 | $self->config->{extra_tag_file} || '' ); 357 | 358 | my @servers; 359 | 360 | if ( defined $self->options->list ) { 361 | my $eol = $self->options->quiet ? ' ' : $/; 362 | my $tab = $self->options->quiet ? '' : "\t"; 363 | if ( !$self->options->list ) { 364 | print( 'Available cluster tags:', $/ ) 365 | unless ( $self->options->quiet ); 366 | print $tab, $_, $eol 367 | foreach ( sort( $self->cluster->list_tags ) ); 368 | 369 | my @external_clusters = $self->cluster->list_external_clusters; 370 | if (@external_clusters) { 371 | print( 'Available external command tags:', $/ ) 372 | unless ( $self->options->quiet ); 373 | print $tab, $_, $eol foreach ( sort(@external_clusters) ); 374 | print $/; 375 | } 376 | } 377 | else { 378 | print 'Tag resolved to hosts: ', $/ 379 | unless ( $self->options->quiet ); 380 | @servers = $self->resolve_names( $self->options->list ); 381 | 382 | foreach my $svr (@servers) { 383 | print $tab, $svr, $eol; 384 | } 385 | print $/; 386 | } 387 | 388 | $self->debug( 389 | 4, 390 | "Full clusters dump: ", 391 | $self->_dump_args_hash( $self->cluster->dump_tags ) 392 | ); 393 | $self->exit_prog(); 394 | } 395 | 396 | if (@ARGV) { 397 | @servers = $self->resolve_names(@ARGV); 398 | } 399 | else { 400 | 401 | #if ( my @default = $self->cluster->get_tag('default') ) { 402 | if ( $self->cluster->get_tag('default') ) { 403 | @servers 404 | 405 | # = $self->resolve_names( @default ); 406 | = $self->resolve_names( $self->cluster->get_tag('default') ); 407 | } 408 | } 409 | 410 | $self->window->create_windows(); 411 | $self->window->create_menubar(); 412 | 413 | $self->window->change_main_window_title(); 414 | 415 | $self->debug( 2, "Capture map events" ); 416 | $self->window->capture_map_events(); 417 | 418 | $self->debug( 0, 'Opening to: ', join( ' ', @servers ) ) 419 | if ( @servers && !$self->options->quiet ); 420 | $self->window->open_client_windows(@servers); 421 | 422 | # Check here if we are tiling windows. Here instead of in func so 423 | # can be tiled from console window if wanted 424 | if ( $self->config->{window_tiling} eq "yes" ) { 425 | $self->window->retile_hosts(); 426 | } 427 | else { 428 | $self->window->show_console(); 429 | } 430 | 431 | $self->window->build_hosts_menu(); 432 | 433 | $self->debug( 2, "Sleeping for a mo" ); 434 | select( undef, undef, undef, 0.5 ); 435 | 436 | $self->window->console_focus; 437 | 438 | # set up external command pipe 439 | if ( $self->config->{external_command_pipe} ) { 440 | 441 | if ( -e $self->config->{external_command_pipe} ) { 442 | $self->debug( 1, "Removing pre-existing external command pipe" ); 443 | unlink( $self->config->{external_command_pipe} ) 444 | or die( 445 | "Could not remove " 446 | . $self->config->{external_command_pipe} 447 | . " prior to creation: " 448 | . $!, 449 | $/ 450 | ); 451 | } 452 | 453 | $self->debug( 2, "Creating external command pipe" ); 454 | 455 | mkfifo( 456 | $self->config->{external_command_pipe}, 457 | oct( $self->config->{external_command_mode} ) 458 | ) 459 | or die( 460 | "Could not create " 461 | . $self->config->{external_command_pipe} . ": ", 462 | $! 463 | ); 464 | 465 | sysopen( 466 | $self->{external_command_pipe_fh}, 467 | $self->config->{external_command_pipe}, 468 | O_NONBLOCK | O_RDONLY 469 | ) 470 | or die( 471 | "Could not open " . $self->config->{external_command_pipe} . ": ", 472 | $! 473 | ); 474 | } 475 | 476 | $self->debug( 2, "Setting up repeat" ); 477 | $self->window->setup_repeat(); 478 | 479 | # Start event loop 480 | $self->debug( 2, "Starting MainLoop" ); 481 | $self->window->mainloop(); 482 | 483 | # make sure we leave program in an expected way 484 | $self->exit_prog(); 485 | } 486 | 487 | 1; 488 | 489 | =item REAPER 490 | 491 | =item add_host_by_name 492 | 493 | =item add_option 494 | 495 | =item build_hosts_menu 496 | 497 | =item capture_map_events 498 | 499 | =item capture_terminal 500 | 501 | =item change_main_window_title 502 | 503 | =item close_inactive_sessions 504 | 505 | =item config 506 | 507 | =item helper 508 | 509 | =item cluster 510 | 511 | =item create_menubar 512 | 513 | =item create_windows 514 | 515 | =item dump_config 516 | 517 | =item getopts 518 | 519 | =item list_tags 520 | 521 | =item evaluate_commands 522 | 523 | =item exit_prog 524 | 525 | =item get_clusters 526 | 527 | =item get_font_size 528 | 529 | =item get_keycode_state 530 | 531 | =item key_event 532 | 533 | =item load_config_defaults 534 | 535 | =item load_configfile 536 | 537 | =item load_keyboard_map 538 | 539 | =item new 540 | 541 | =item open_client_windows 542 | 543 | =item options 544 | 545 | =item parse_config_file 546 | 547 | =item pick_color 548 | 549 | =item populate_send_menu 550 | 551 | =item populate_send_menu_entries_from_xml 552 | 553 | =item re_add_closed_sessions 554 | 555 | =item remove_repeated_servers 556 | 557 | =item resolve_names 558 | 559 | =item slash_slash_equal 560 | 561 | An implementation of the //= operator that works on older Perls. 562 | slash_slash_equal($a, 0) is equivalent to $a //= 0 563 | 564 | =item retile_hosts 565 | 566 | =item run 567 | 568 | =item send_resizemove 569 | 570 | =item send_text 571 | 572 | =item send_text_to_all_servers 573 | 574 | =item set_all_active 575 | 576 | =item set_half_inactive 577 | 578 | =item setup_repeat 579 | 580 | =item send_variable_text_to_all_servers 581 | 582 | =item show_console 583 | 584 | =item show_history 585 | 586 | =item substitute_macros 587 | 588 | =item terminate_host 589 | 590 | =item toggle_active_state 591 | 592 | =item update_display_text 593 | 594 | =item window 595 | 596 | Method to access associated window module 597 | 598 | =item write_default_user_config 599 | 600 | =back 601 | 602 | =head1 BUGS 603 | 604 | Please report any bugs or feature requests via L<https://github.com/duncs/clusterssh/issues>. 605 | 606 | =head1 SUPPORT 607 | 608 | You can find documentation for this module with the perldoc command. 609 | 610 | perldoc App::ClusterSSH 611 | 612 | You can also look for information at: 613 | 614 | =over 4 615 | 616 | =item * Github issue tracker 617 | 618 | L<https://github.com/duncs/clusterssh/issues> 619 | 620 | =item * AnnoCPAN: Annotated CPAN documentation 621 | 622 | L<http://annocpan.org/dist/App-ClusterSSH> 623 | 624 | =item * CPAN Ratings 625 | 626 | L<http://cpanratings.perl.org/d/App-ClusterSSH> 627 | 628 | =item * Search CPAN 629 | 630 | L<http://search.cpan.org/dist/App-ClusterSSH/> 631 | 632 | =back 633 | 634 | =head1 ACKNOWLEDGEMENTS 635 | 636 | Please see the THANKS file from the original distribution. 637 | 638 | =cut 639 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Base.pm: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | package App::ClusterSSH::Base; 5 | 6 | # ABSTRACT: App::ClusterSSH::Base - Base object provding utility functions 7 | 8 | =head1 SYNOPSIS 9 | 10 | use base qw/ App::ClusterSSH::Base /; 11 | 12 | # in object new method 13 | sub new { 14 | ( $class, $arg_ref ) = @_; 15 | my $self = $class->SUPER::new($arg_ref); 16 | return $self; 17 | } 18 | 19 | =head1 DESCRIPTION 20 | 21 | Base object to provide some utility functions on objects - should not be 22 | used directly 23 | 24 | =cut 25 | 26 | use Carp; 27 | use App::ClusterSSH::L10N; 28 | 29 | use Module::Load; 30 | 31 | use Exception::Class 1.31 ( 32 | 'App::ClusterSSH::Exception', 33 | 'App::ClusterSSH::Exception::Config' => { 34 | fields => 'unknown_config', 35 | }, 36 | 'App::ClusterSSH::Exception::Cluster', 37 | 'App::ClusterSSH::Exception::LoadFile', 38 | 'App::ClusterSSH::Exception::Helper', 39 | 'App::ClusterSSH::Exception::Getopt', 40 | ); 41 | 42 | my $debug_level = $ENV{CLUSTERSSH_DEBUG} || 0; 43 | our $language = 'en'; 44 | our $language_handle; 45 | our $app_configuration; 46 | 47 | sub new { 48 | my ( $class, %args ) = @_; 49 | 50 | my $config = { 51 | lang => 'en', 52 | %args, 53 | }; 54 | 55 | my $self = bless $config, $class; 56 | 57 | $self->set_debug_level( $config->{debug} ) if ( $config->{debug} ); 58 | $self->set_lang( $config->{lang} ); 59 | 60 | $self->debug( 61 | 7, 62 | $self->loc( 'Arguments to [_1]->new(): ', $class ), 63 | $self->_dump_args_hash(%args), 64 | ); 65 | 66 | return $self; 67 | } 68 | 69 | sub _dump_args_hash { 70 | my ( $class, %args ) = @_; 71 | my $string = $/; 72 | 73 | foreach ( sort( keys(%args) ) ) { 74 | $string .= "\t"; 75 | $string .= $_; 76 | $string .= ' => '; 77 | if ( ref( $args{$_} ) eq 'ARRAY' ) { 78 | $string .= "@{ $args{$_} }"; 79 | } 80 | else { 81 | $string .= $args{$_}; 82 | } 83 | $string .= ','; 84 | $string .= $/; 85 | } 86 | chomp($string); 87 | 88 | return $string; 89 | } 90 | 91 | sub _translate { 92 | my @args = @_; 93 | if ( !$language_handle ) { 94 | $language_handle = App::ClusterSSH::L10N->get_handle($language); 95 | } 96 | 97 | return $language_handle->maketext(@args); 98 | } 99 | 100 | sub loc { 101 | my ( $self, @args ) = @_; 102 | $_ ||= q{} foreach (@args); 103 | return _translate(@args); 104 | } 105 | 106 | sub set_lang { 107 | my ( $self, $lang ) = @_; 108 | $self->debug( 6, $self->loc( 'Setting language to "[_1]"', $lang ), ); 109 | return $self; 110 | } 111 | 112 | sub set_debug_level { 113 | my ( $self, $level ) = @_; 114 | if ( !defined $level ) { 115 | croak( 116 | App::ClusterSSH::Exception->throw( 117 | error => _translate('Debug level not provided') 118 | ) 119 | ); 120 | } 121 | if ( $level > 9 ) { 122 | $level = 9; 123 | } 124 | $debug_level = $level; 125 | return $self; 126 | } 127 | 128 | sub debug_level { 129 | my ($self) = @_; 130 | return $debug_level; 131 | } 132 | 133 | sub stdout_output { 134 | my ( $self, @text ) = @_; 135 | print @text, $/; 136 | return $self; 137 | } 138 | 139 | sub debug { 140 | my ( $self, $level, @text ) = @_; 141 | if ( $level <= $debug_level ) { 142 | $self->stdout_output(@text); 143 | } 144 | return $self; 145 | } 146 | 147 | sub exit { 148 | my ($self) = @_; 149 | 150 | exit; 151 | } 152 | 153 | sub config { 154 | my ($self) = @_; 155 | 156 | if ( !$app_configuration ) { 157 | croak( 158 | App::ClusterSSH::Exception->throw( 159 | _translate('config has not yet been set') 160 | ) 161 | ); 162 | } 163 | 164 | return $self->{parent}->{config} 165 | if $self->{parent} 166 | && ref $self->{parent} eq "HASH" 167 | && $self->{parent}->{config}; 168 | 169 | return $app_configuration; 170 | } 171 | 172 | sub options { 173 | my ($self) = @_; 174 | return $self->{parent}->{options} 175 | if $self->{parent} && $self->{parent}->{options}; 176 | return; 177 | } 178 | 179 | sub set_config { 180 | my ( $self, $config ) = @_; 181 | 182 | if ($app_configuration) { 183 | croak( 184 | App::ClusterSSH::Exception->throw( 185 | _translate('config has already been set') 186 | ) 187 | ); 188 | } 189 | 190 | if ( !$config ) { 191 | croak( 192 | App::ClusterSSH::Exception->throw( 193 | _translate('passed config is empty') 194 | ) 195 | ); 196 | } 197 | 198 | $self->debug( 3, _translate('Setting app configuration') ); 199 | 200 | $app_configuration = $config; 201 | 202 | return $self; 203 | } 204 | 205 | sub load_file { 206 | my ( $self, %args ) = @_; 207 | 208 | if ( !$args{filename} ) { 209 | croak( 210 | App::ClusterSSH::Exception->throw( 211 | error => '"filename" arg not passed' 212 | ) 213 | ); 214 | } 215 | 216 | if ( !$args{type} ) { 217 | croak( 218 | App::ClusterSSH::Exception->throw( 219 | error => '"type" arg not passed' 220 | ) 221 | ); 222 | } 223 | 224 | $self->debug( 2, 'Loading in config file: ', $args{filename} ); 225 | 226 | if ( !-e $args{filename} ) { 227 | croak( 228 | App::ClusterSSH::Exception::LoadFile->throw( 229 | error => $self->loc( 230 | 'Unable to read file [_1]: [_2]' . $/, $args{filename}, 231 | $! 232 | ), 233 | ), 234 | ); 235 | } 236 | 237 | my $regexp 238 | = $args{type} eq 'config' ? qr/\s*(\S+)\s*=\s*(.*)/ 239 | : $args{type} eq 'cluster' ? qr/\s*(\S+)\s+(.*)/ 240 | : croak( 241 | App::ClusterSSH::Exception::LoadFile->throw( 242 | error => 'Unknown arg type: ', 243 | $args{type} 244 | ) 245 | ); 246 | 247 | open( my $fh, '<', $args{filename} ) 248 | or croak( 249 | App::ClusterSSH::Exception::LoadFile->throw( 250 | error => $self->loc( 251 | "Unable to read file [_1]: [_2]", 252 | $args{filename}, $! 253 | ) 254 | ), 255 | ); 256 | 257 | my %results; 258 | my $line; 259 | 260 | while ( defined( $line = <$fh> ) ) { 261 | next 262 | if ( $line =~ /^\s*$/ || $line =~ /^#/ ) 263 | ; # ignore blank lines & commented lines 264 | 265 | $line =~ s/\s*#.*//; # remove comments from remaining lines 266 | $line =~ s/\s*$//; # remove trailing whitespace 267 | 268 | # look for continuation lines 269 | chomp $line; 270 | if ( $line =~ s/\\\s*$// ) { 271 | $line .= <$fh>; 272 | redo unless eof($fh); 273 | } 274 | 275 | next unless $line =~ $regexp; 276 | my ( $key, $value ) = ( $1, $2 ); 277 | if ( defined $key && defined $value ) { 278 | if ( $results{$key} ) { 279 | $results{$key} .= ' ' . $value; 280 | } 281 | else { 282 | $results{$key} = $value; 283 | } 284 | $self->debug( 3, "$key=$value" ); 285 | $self->debug( 7, "entry now reads: $key=$results{$key}" ); 286 | } 287 | } 288 | 289 | close($fh) 290 | or croak( 291 | App::ClusterSSH::Exception::LoadFile->throw( 292 | error => "Could not close $args{filename} after reading: $!" 293 | ), 294 | ); 295 | 296 | return %results; 297 | } 298 | 299 | sub parent { 300 | my ($self) = @_; 301 | return $self->{parent}; 302 | } 303 | 304 | sub sort { 305 | my $self = shift; 306 | 307 | # if the user has asked for natural sorting we need to include an extra 308 | # module 309 | my $config = $self->config(); 310 | 311 | # Make sure the configuration object has been set correctly before 312 | # referencing anything 313 | if ( ref $config eq "HASH" && $config->{'use_natural_sort'} ) { 314 | eval { Module::Load::load('Sort::Naturally'); }; 315 | if ($@) { 316 | warn( 317 | "natural sorting requested but unable to load Sort::Naturally: $@\n" 318 | ); 319 | } 320 | else { 321 | my $sort = sub { Sort::Naturally::nsort(@_) }; 322 | return $sort; 323 | } 324 | } 325 | 326 | my $sort = sub { sort @_ }; 327 | return $sort; 328 | } 329 | 330 | 1; 331 | 332 | =head1 METHODS 333 | 334 | These extra methods are provided on the object 335 | 336 | =over 4 337 | 338 | =item $obj = App::ClusterSSH::Base->new({ arg => val, }); 339 | 340 | Creates object. In higher debug levels the args are printed out. 341 | 342 | =item $obj->id 343 | 344 | Return the unique id of the object for use in subclasses, such as 345 | 346 | $info_for{ $self->id } = $info 347 | 348 | =item $obj->debug_level(); 349 | 350 | Returns current debug level 351 | 352 | =item $obj->set_debug_level( n ) 353 | 354 | Set debug level to 'n' for all child objects. 355 | 356 | =item $obj->debug($level, @text) 357 | 358 | Output @text on STDOUT if $level is the same or lower that debug_level 359 | 360 | =item $obj->set_lang 361 | 362 | Set the Locale::Maketext language. Defaults to 'en'. Expects the 363 | App::ClusterSSH/L10N/{lang}.pm module to exist and contain all relevant 364 | translations, else defaults to English. 365 | 366 | =item $obj->loc('text to translate [_1]') 367 | 368 | Using the App::ClusterSSH/L10N/{lang}.pm module convert the given text to 369 | appropriate language. See L<App::ClusterSSH::L10N> for more details. Essentially 370 | a wrapper to maketext in Locale::Maketext 371 | 372 | =item $obj->stdout_output(@); 373 | 374 | Output text on STDOUT. 375 | 376 | =item $obj->parent; 377 | 378 | Returned the object that is the parent of this one, if it was set when the 379 | object was created 380 | 381 | =item %obj->options; 382 | 383 | Accessor to configured options, if it is set up by this point 384 | 385 | =item $obj->exit; 386 | 387 | Stub to allow program to exit neatly from wherever in the code 388 | 389 | =item $config = $obj->config; 390 | 391 | Returns whatever configuration object has been set up. Croaks if set_config 392 | hasnt been called 393 | 394 | =item $obj->set_config($config); 395 | 396 | Set the config to the given value - croaks if has already been called 397 | 398 | =item $sort = $obj->sort 399 | 400 | Code reference used to sort lists; if configured (and installed) use 401 | Sort;:Naturally, else use perl sort 402 | 403 | =item %results = $obj->load_file( filename => '/path/to/file', type => '(cluster|config}' ) 404 | 405 | Load in the specified file and return a hash, parsing the file depending on 406 | wther it is a config file (key = value) or cluster file (key value) 407 | 408 | =back 409 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Cluster.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::Cluster; 5 | 6 | # ABSTRACT: App::ClusterSSH::Cluster - Object representing cluster configuration 7 | 8 | =head1 SYNOPSIS 9 | 10 | =head1 DESCRIPTION 11 | 12 | Object representing application configuration 13 | 14 | =cut 15 | 16 | use Carp; 17 | use Try::Tiny 0.28; 18 | use English qw( -no_match_vars ); 19 | 20 | use base qw/ App::ClusterSSH::Base /; 21 | use App::ClusterSSH::Range; 22 | 23 | our $master_object_ref; 24 | 25 | sub new { 26 | my ( $class, %args ) = @_; 27 | 28 | if ( !$master_object_ref ) { 29 | $master_object_ref = $class->SUPER::new(%args); 30 | } 31 | 32 | return $master_object_ref; 33 | } 34 | 35 | sub get_cluster_entries { 36 | my ( $self, @files ) = @_; 37 | 38 | for my $file ( '/etc/clusters', $ENV{HOME} . '/.clusterssh/clusters', 39 | @files ) 40 | { 41 | $self->debug( 3, 'Loading in clusters from: ', $file ); 42 | $self->read_cluster_file($file); 43 | } 44 | 45 | return $self; 46 | } 47 | 48 | sub get_tag_entries { 49 | my ( $self, @files ) = @_; 50 | 51 | for my $file ( '/etc/tags', $ENV{HOME} . '/.clusterssh/tags', @files ) { 52 | $self->debug( 3, 'Loading in tags from: ', $file ); 53 | $self->read_tag_file($file); 54 | } 55 | 56 | return $self; 57 | } 58 | 59 | sub list_external_clusters { 60 | my ( $self, ) = @_; 61 | 62 | my @list = $self->_run_external_clusters('-L'); 63 | return wantarray 64 | ? sort @list 65 | : scalar @list; 66 | } 67 | 68 | sub get_external_clusters { 69 | my ( $self, @tags ) = @_; 70 | 71 | return $self->_run_external_clusters(@tags); 72 | } 73 | 74 | sub _run_external_clusters { 75 | my ( $self, @args ) = @_; 76 | 77 | my $external_command = $self->parent->config->{external_cluster_command}; 78 | 79 | if ( !$external_command || !-x $external_command ) { 80 | $self->debug( 81 | 1, 82 | 'Cannot run external cluster command: ', 83 | $external_command || '' 84 | ); 85 | return; 86 | } 87 | 88 | $self->debug( 3, 'Running tags through external command' ); 89 | $self->debug( 4, 'External command: ', $external_command ); 90 | $self->debug( 3, 'Args ', join( ',', @args ) ); 91 | 92 | my $command = "$external_command @args"; 93 | 94 | $self->debug( 3, 'Running ', $command ); 95 | 96 | my $result; 97 | my $return_code; 98 | { 99 | local $SIG{CHLD} = undef; 100 | $result = qx/ $command /; 101 | $return_code = $CHILD_ERROR >> 8; 102 | } 103 | chomp($result); 104 | 105 | $self->debug( 3, "Result: $result" ); 106 | $self->debug( 3, "Return code: $return_code" ); 107 | 108 | if ( $return_code != 0 ) { 109 | croak( 110 | App::ClusterSSH::Exception::Cluster->throw( 111 | error => $self->loc( 112 | "External command failure.\nCommand: [_1]\nReturn Code: [_2]", 113 | $command, 114 | $return_code, 115 | ), 116 | ) 117 | ); 118 | } 119 | 120 | my @results = split / /, $result; 121 | 122 | return @results; 123 | } 124 | 125 | sub expand_filename { 126 | my ( $self, $filename ) = @_; 127 | my $home; 128 | 129 | # try to determine the home directory 130 | if ( !defined( $home = $ENV{'HOME'} ) ) { 131 | $home = ( getpwuid($>) )[5]; 132 | } 133 | if ( !defined($home) ) { 134 | $self->debug( 3, 'No home found so leaving filename ', 135 | $filename, ' unexpanded' ); 136 | return $filename; 137 | } 138 | $self->debug( 4, 'Using ', $home, ' as home directory' ); 139 | 140 | # expand ~ or $HOME 141 | my $new_name = $filename; 142 | $new_name =~ s!^~/!$home/!g; 143 | $new_name =~ s!^\$HOME/!$home/!g; 144 | 145 | $self->debug( 2, 'Expanding ', $filename, ' to ', $new_name ) 146 | unless ( $filename eq $new_name ); 147 | 148 | return $new_name; 149 | } 150 | 151 | sub read_tag_file { 152 | my ( $self, $filename ) = @_; 153 | 154 | $filename = $self->expand_filename($filename); 155 | 156 | $self->debug( 2, 'Reading tags from file ', $filename ); 157 | if ( -f $filename ) { 158 | my %hosts 159 | = $self->load_file( type => 'cluster', filename => $filename ); 160 | foreach my $host ( keys %hosts ) { 161 | $self->debug( 4, "Got entry for $host on tags $hosts{$host}" ); 162 | $self->register_host( $host, split( /\s+/, $hosts{$host} ) ); 163 | } 164 | } 165 | else { 166 | $self->debug( 2, 'No file found to read' ); 167 | } 168 | return $self; 169 | } 170 | 171 | sub read_cluster_file { 172 | my ( $self, $filename ) = @_; 173 | 174 | $filename = $self->expand_filename($filename); 175 | 176 | $self->debug( 2, 'Reading clusters from file ', $filename ); 177 | 178 | if ( -f $filename ) { 179 | my %tags 180 | = $self->load_file( type => 'cluster', filename => $filename ); 181 | 182 | foreach my $tag ( keys %tags ) { 183 | $self->register_tag( $tag, split( /\s+/, $tags{$tag} ) ); 184 | } 185 | } 186 | else { 187 | $self->debug( 2, 'No file found to read' ); 188 | } 189 | return $self; 190 | } 191 | 192 | sub register_host { 193 | my ( $self, $node, @tags ) = @_; 194 | $self->debug( 2, "Registering node $node on tags:", join( ' ', @tags ) ); 195 | 196 | @tags = $self->expand_glob( 'node', $node, @tags ); 197 | 198 | foreach my $tag (@tags) { 199 | if ( $self->{tags}->{$tag} ) { 200 | $self->{tags}->{$tag} 201 | = [ sort @{ $self->{tags}->{$tag} }, $node ]; 202 | } 203 | else { 204 | $self->{tags}->{$tag} = [$node]; 205 | } 206 | 207 | #push(@{ $self->{tags}->{$tag} }, $node); 208 | } 209 | return $self; 210 | } 211 | 212 | sub register_tag { 213 | my ( $self, $tag, @nodes ) = @_; 214 | 215 | #warn "b4 nodes=@nodes"; 216 | @nodes = $self->expand_glob( 'tag', $tag, @nodes ); 217 | 218 | #warn "af nodes=@nodes"; 219 | 220 | $self->debug( 2, "Registering tag $tag: ", join( ' ', @nodes ) ); 221 | 222 | $self->{tags}->{$tag} = \@nodes; 223 | 224 | return $self; 225 | } 226 | 227 | sub expand_glob { 228 | my ( $self, $type, $name, @items ) = @_; 229 | 230 | my @expanded; 231 | my $range = App::ClusterSSH::Range->new(); 232 | 233 | # skip expanding anything that appears to have nasty metachars 234 | if ( !grep {m/[\`\!\$;]/} @items ) { 235 | 236 | $self->debug( 4, "Non-expanded: @items" ); 237 | 238 | @items = $range->expand(@items); 239 | 240 | # run glob over anything left incase there are numeric and textual ranges 241 | @expanded = map { glob $_ } @items; 242 | $self->debug( 4, "Final expansion: @expanded" ); 243 | } 244 | else { 245 | warn( 246 | $self->loc( 247 | "Bad characters picked up in [_1] '[_2]': [_3]", 248 | $type, $name, join( ' ', @items ) 249 | ), 250 | ); 251 | } 252 | 253 | return @expanded; 254 | } 255 | 256 | sub get_tag { 257 | my ( $self, $tag ) = @_; 258 | 259 | if ( $self->{tags}->{$tag} ) { 260 | $self->debug( 261 | 2, 262 | "Retrieving tag $tag: ", 263 | join( ' ', sort @{ $self->{tags}->{$tag} } ) 264 | ); 265 | 266 | return wantarray 267 | ? sort @{ $self->{tags}->{$tag} } 268 | : scalar @{ $self->{tags}->{$tag} }; 269 | } 270 | 271 | $self->debug( 2, "Tag $tag is not registered" ); 272 | return; 273 | } 274 | 275 | sub list_tags { 276 | my ($self) = @_; 277 | return wantarray 278 | ? sort keys( %{ $self->{tags} } ) 279 | : scalar keys( %{ $self->{tags} } ); 280 | } 281 | 282 | sub dump_tags { 283 | my ($self) = @_; 284 | return %{ $self->{tags} }; 285 | } 286 | 287 | #use overload ( 288 | # q{""} => sub { 289 | # my ($self) = @_; 290 | # return $self->{hostname}; 291 | # }, 292 | # fallback => 1, 293 | #); 294 | 295 | 1; 296 | 297 | =head1 METHODS 298 | 299 | =over 4 300 | 301 | =item $cluster=ClusterSSH::Cluster->new(); 302 | 303 | Create a new object. Object should be common across all invocations. 304 | 305 | =item $cluster->get_cluster_entries($filename); 306 | 307 | Read in /etc/clusters, $HOME/.clusterssh/clusters and any other given 308 | file name and register the tags found. 309 | 310 | =item @external_tags=list_external_clusters() 311 | 312 | Call an external script suing C<-L> to list available tags 313 | 314 | =item @resolved_tags=get_external_clusters(@tags) 315 | 316 | Use an external script to resolve C<@tags> into hostnames. 317 | 318 | =item $cluster->get_tag_entries($filename); 319 | 320 | Read in /etc/tags, $HOME/.clusterssh/tags and any other given 321 | file name and register the tags found. 322 | 323 | =item $cluster->read_cluster_file($filename); 324 | 325 | Read in the given cluster file and register the tags found 326 | 327 | =item $cluster->expand_filename($filename); 328 | 329 | Expand ~ or $HOME in a filename 330 | 331 | =item $cluster->read_tag_file($filename); 332 | 333 | Read in the given tag file and register the tags found 334 | 335 | =item $cluster->register_tag($tag,@hosts); 336 | 337 | Register the given tag name with the given host names. 338 | 339 | =item $cluster->register_host($host,@tags); 340 | 341 | Register the given host on the provided tags. 342 | 343 | =item @entries = $cluster->get_tag('tag'); 344 | 345 | =item $entries = $cluster->get_tag('tag'); 346 | 347 | Retrieve all entries for the given tag. Returns an array of hosts or 348 | the number of hosts in the array depending on context. 349 | 350 | =item @tags = $cluster->list_tags(); 351 | 352 | Return an array of all available tag names 353 | 354 | =item %tags = $cluster->dump_tags(); 355 | 356 | Returns a hash of all tag data. 357 | 358 | =item @tags = $cluster->expand_glob( $type, $name, @items ); 359 | 360 | Use shell expansion against each item in @items, where $type is either 'node', or 'tag' and $name is the node or tag name. These attributes are presented to the user in the event of an issue with the expanion to track down the source. 361 | 362 | =back 363 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Config.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::Config; 5 | 6 | # ABSTRACT: ClusterSSH::Config - Object representing application configuration 7 | 8 | =head1 SYNOPSIS 9 | 10 | =head1 DESCRIPTION 11 | 12 | Object representing application configuration 13 | 14 | =cut 15 | 16 | use Carp; 17 | use Try::Tiny; 18 | 19 | use FindBin qw($Script); 20 | use File::Copy; 21 | 22 | use base qw/ App::ClusterSSH::Base /; 23 | use App::ClusterSSH::Cluster; 24 | 25 | my $clusters; 26 | my %old_clusters; 27 | my @app_specific = (qw/ command title comms method parent /); 28 | 29 | # list of config items to not write out when writing the default config 30 | my @ignore_default_config = (qw/ user /); 31 | 32 | my %default_config = ( 33 | terminal => "xterm", 34 | terminal_args => "", 35 | terminal_title_opt => "-T", 36 | terminal_colorize => 1, 37 | terminal_bg_style => 'dark', 38 | terminal_allow_send_events => "-xrm '*.VT100.allowSendEvents:true'", 39 | terminal_font => "6x13", 40 | terminal_size => "80x24", 41 | 42 | use_hotkeys => "yes", 43 | key_quit => "Alt-q", 44 | key_addhost => "Control-Shift-plus", 45 | key_clientname => "Alt-n", 46 | key_history => "Alt-h", 47 | key_localname => "Alt-l", 48 | key_retilehosts => "Alt-r", 49 | key_macros_enable => "Alt-p", 50 | key_paste => "Control-v", 51 | key_username => "Alt-u", 52 | key_user_1 => "Alt-1", 53 | key_user_2 => "Alt-2", 54 | key_user_3 => "Alt-3", 55 | key_user_4 => "Alt-4", 56 | mouse_paste => "Button-2", 57 | auto_quit => "yes", 58 | auto_close => 5, 59 | use_natural_sort => 0, 60 | window_tiling => "yes", 61 | window_tiling_direction => "right", 62 | console_position => "", 63 | 64 | screen_reserve_top => 0, 65 | screen_reserve_bottom => 60, 66 | screen_reserve_left => 0, 67 | screen_reserve_right => 0, 68 | 69 | terminal_reserve_top => 5, 70 | terminal_reserve_bottom => 0, 71 | terminal_reserve_left => 5, 72 | terminal_reserve_right => 0, 73 | 74 | terminal_decoration_height => 10, 75 | terminal_decoration_width => 8, 76 | 77 | console => 'console', 78 | console_args => '', 79 | rsh => 'rsh', 80 | rsh_args => "", 81 | telnet => 'telnet', 82 | telnet_args => "", 83 | ssh => 'ssh', 84 | ssh_args => "", 85 | sftp => 'sftp', 86 | sftp_args => "", 87 | 88 | extra_tag_file => '', 89 | extra_cluster_file => '', 90 | external_cluster_command => '', 91 | external_command_mode => '0600', 92 | external_command_pipe => '', 93 | 94 | unmap_on_redraw => "no", # Debian #329440 95 | 96 | show_history => 0, 97 | history_width => 40, 98 | history_height => 10, 99 | 100 | command => q{}, 101 | command_pre => q{}, 102 | command_post => q{}, 103 | hide_menu => 0, 104 | max_host_menu_items => 30, 105 | 106 | macros_enabled => 'yes', 107 | macro_servername => '%s', 108 | macro_hostname => '%h', 109 | macro_username => '%u', 110 | macro_newline => '%n', 111 | macro_version => '%v', 112 | macro_user_1 => '%1', 113 | macro_user_2 => '%2', 114 | macro_user_3 => '%3', 115 | macro_user_4 => '%4', 116 | 117 | macro_user_1_command => '', 118 | macro_user_2_command => '', 119 | macro_user_3_command => '', 120 | macro_user_4_command => '', 121 | hostname_override => '', 122 | 123 | max_addhost_menu_cluster_items => 6, 124 | menu_send_autotearoff => 0, 125 | menu_host_autotearoff => 0, 126 | 127 | unique_servers => 0, 128 | use_all_a_records => 0, 129 | 130 | send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu', 131 | 132 | auto_wm_decoration_offsets => "no", # Debian #842965 133 | 134 | # don't set username here as takes precendence over ssh config 135 | user => '', 136 | rows => -1, 137 | cols => -1, 138 | 139 | fillscreen => "no", 140 | 141 | ); 142 | 143 | sub new { 144 | my ( $class, %args ) = @_; 145 | 146 | my $self = $class->SUPER::new(%default_config); 147 | 148 | ( my $comms = $Script ) =~ s/^c//; 149 | 150 | $comms = 'telnet' if ( $comms eq 'tel' ); 151 | $comms = 'console' if ( $comms eq 'con' ); 152 | $comms = 'ssh' if ( $comms eq 'lusterssh' ); 153 | $comms = 'sftp' if ( $comms eq 'sftp' ); 154 | 155 | # list of allowed comms methods 156 | if ( 'ssh rsh telnet sftp console' !~ m/\b$comms\b/ ) { 157 | $self->{comms} = 'ssh'; 158 | } 159 | else { 160 | $self->{comms} = $comms; 161 | } 162 | 163 | $self->{title} = uc($Script); 164 | 165 | $clusters = App::ClusterSSH::Cluster->new(); 166 | 167 | return $self->validate_args(%args); 168 | } 169 | 170 | sub validate_args { 171 | my ( $self, %args ) = @_; 172 | 173 | my @unknown_config = (); 174 | 175 | foreach my $config ( sort( keys(%args) ) ) { 176 | if ( grep /$config/, @app_specific ) { 177 | 178 | # $self->{$config} ||= 'unknown'; 179 | next; 180 | } 181 | 182 | if ( exists $self->{$config} ) { 183 | $self->{$config} = $args{$config}; 184 | } 185 | else { 186 | push( @unknown_config, $config ); 187 | } 188 | } 189 | 190 | if (@unknown_config) { 191 | croak( 192 | App::ClusterSSH::Exception::Config->throw( 193 | unknown_config => \@unknown_config, 194 | error => $self->loc( 195 | 'Unknown configuration parameters: [_1]' . $/, 196 | join( ',', @unknown_config ) 197 | ) 198 | ) 199 | ); 200 | } 201 | 202 | if ( !$self->{comms} ) { 203 | croak( 204 | App::ClusterSSH::Exception::Config->throw( 205 | error => $self->loc( 'Invalid variable: comms' . $/ ), 206 | ), 207 | ); 208 | } 209 | 210 | if ( !$self->{ $self->{comms} } ) { 211 | croak( 212 | App::ClusterSSH::Exception::Config->throw( 213 | error => $self->loc( 214 | 'Invalid variable: [_1]' . $/, 215 | $self->{comms} 216 | ), 217 | ), 218 | ); 219 | } 220 | 221 | # check the terminal has been found correctly 222 | # looking for the terminal should not be fatal 223 | if ( !-e $self->{terminal} ) { 224 | eval { $self->{terminal} = $self->find_binary( $self->{terminal} ); }; 225 | if ($@) { 226 | warn $@->message; 227 | } 228 | } 229 | 230 | return $self; 231 | } 232 | 233 | sub parse_config_file { 234 | my ( $self, $config_file ) = @_; 235 | 236 | $self->debug( 2, 'Loading in config file: ', $config_file ); 237 | 238 | # if ( !-e $config_file || !-r $config_file ) { 239 | # croak( 240 | # App::ClusterSSH::Exception::Config->throw( 241 | # error => $self->loc( 242 | # 'File [_1] does not exist or cannot be read' . $/, 243 | # $config_file 244 | # ), 245 | # ), 246 | # ); 247 | # } 248 | # 249 | # open( CFG, $config_file ) or die("Couldnt open $config_file: $!"); 250 | # my $l; 251 | # my %read_config; 252 | # while ( defined( $l = <CFG> ) ) { 253 | # next 254 | # if ( $l =~ /^\s*$/ || $l =~ /^#/ ) 255 | # ; # ignore blank lines & commented lines 256 | # $l =~ s/#.*//; # remove comments from remaining lines 257 | # $l =~ s/\s*$//; # remove trailing whitespace 258 | # 259 | # # look for continuation lines 260 | # chomp $l; 261 | # if ( $l =~ s/\\\s*$// ) { 262 | # $l .= <CFG>; 263 | # redo unless eof(CFG); 264 | # } 265 | # 266 | # next unless $l =~ m/\s*(\S+)\s*=\s*(.*)\s*/; 267 | # my ( $key, $value ) = ( $1, $2 ); 268 | # if ( defined $key && defined $value ) { 269 | # $read_config{$key} = $value; 270 | # $self->debug( 3, "$key=$value" ); 271 | # } 272 | # } 273 | # close(CFG); 274 | 275 | my %read_config; 276 | %read_config 277 | = $self->load_file( type => 'config', filename => $config_file ); 278 | 279 | # grab any clusters from the config before validating it 280 | if ( $read_config{clusters} ) { 281 | $self->debug( 3, "Picked up clusters defined in $config_file" ); 282 | foreach my $cluster ( sort split / /, $read_config{clusters} ) { 283 | if ( $read_config{$cluster} ) { 284 | $clusters->register_tag( $cluster, 285 | split( / /, $read_config{$cluster} ) ); 286 | $old_clusters{$cluster} = $read_config{$cluster}; 287 | delete( $read_config{$cluster} ); 288 | } 289 | } 290 | delete( $read_config{clusters} ); 291 | } 292 | 293 | # tidy up entries, just in case 294 | $read_config{terminal_font} =~ s/['"]//g 295 | if ( $read_config{terminal_font} ); 296 | 297 | $self->validate_args(%read_config); 298 | 299 | # Look at the user macros and if not set remove the hotkey for them 300 | for my $i (qw/ 1 2 3 4 /) { 301 | if ( !$self->{"macro_user_${i}_command"} ) { 302 | delete $self->{"key_user_${i}"}; 303 | } 304 | } 305 | 306 | return $self; 307 | } 308 | 309 | sub load_configs { 310 | my ( $self, @configs ) = @_; 311 | 312 | for my $config ( 313 | '/etc/csshrc', 314 | $ENV{HOME} . '/.csshrc', 315 | $ENV{HOME} . '/.clusterssh/config', 316 | ) 317 | { 318 | $self->parse_config_file($config) if ( -e $config && !-d _ ); 319 | } 320 | 321 | # write out default config file if necesasry 322 | try { 323 | $self->write_user_config_file(); 324 | } 325 | catch { 326 | warn $_, $/; 327 | }; 328 | 329 | # Attempt to load in provided config files. Also look for anything 330 | # relative to config directory 331 | for my $config (@configs) { 332 | next unless ($config); # can be null when passed from Getopt::Long 333 | $self->parse_config_file($config) if ( -e $config && !-d _ ); 334 | 335 | my $file = $ENV{HOME} . '/.clusterssh/config_' . $config; 336 | $self->parse_config_file($file) if ( -e $file && !-d _ ); 337 | } 338 | 339 | # Override confuration via environment variable using cssh_ prefix 340 | # eg: terminal_size => cssh_terminal_size 341 | foreach my $config_key ( sort( keys(%default_config) ) ) { 342 | my $env_config_key = "cssh_" . $config_key; 343 | if ( exists $ENV{ uc($env_config_key) } ) { 344 | $env_config_key = uc($env_config_key); 345 | } 346 | if ( exists $ENV{$env_config_key} ) { 347 | $self->{$config_key} = $ENV{$env_config_key}; 348 | } 349 | } 350 | 351 | return $self; 352 | } 353 | 354 | sub write_user_config_file { 355 | my ($self) = @_; 356 | 357 | # attempt to move the old config file to one side 358 | if ( -f "$ENV{HOME}/.csshrc" ) { 359 | eval { move( "$ENV{HOME}/.csshrc", "$ENV{HOME}/.csshrc.DISABLED" ) }; 360 | 361 | if ($@) { 362 | croak( 363 | App::ClusterSSH::Exception::Config->throw( 364 | error => $self->loc( 365 | 'Unable to move [_1] to [_2]: [_3]' . $/, 366 | '$HOME/.csshrc', '$HOME/.csshrc.DISABLED', $@ 367 | ), 368 | ) 369 | ); 370 | } 371 | else { 372 | warn( 373 | $self->loc( 374 | 'Moved [_1] to [_2]' . $/, '$HOME/.csshrc', 375 | '$HOME/.csshrc.DISABLED' 376 | ), 377 | ); 378 | } 379 | } 380 | 381 | return if ( -f "$ENV{HOME}/.clusterssh/config" ); 382 | 383 | if ( !-d "$ENV{HOME}/.clusterssh" ) { 384 | if ( !mkdir("$ENV{HOME}/.clusterssh") ) { 385 | croak( 386 | App::ClusterSSH::Exception::Config->throw( 387 | error => $self->loc( 388 | 'Unable to create directory [_1]: [_2]' . $/, 389 | '$HOME/.clusterssh', $! 390 | ), 391 | ), 392 | ); 393 | 394 | } 395 | } 396 | 397 | # Debian #673507 - migrate clusters prior to writing ~/.clusterssh/config 398 | # in order to update the extra_cluster_file property 399 | if (%old_clusters) { 400 | if ( open( my $fh, ">", "$ENV{HOME}/.clusterssh/clusters" ) ) { 401 | print $fh '# ' 402 | . $self->loc('Tag definitions moved from old .csshrc file'), 403 | $/; 404 | foreach ( sort( keys(%old_clusters) ) ) { 405 | print $fh $_, ' ', join( ' ', $old_clusters{$_} ), $/; 406 | } 407 | close($fh); 408 | } 409 | else { 410 | croak( 411 | App::ClusterSSH::Exception::Config->throw( 412 | error => $self->loc( 413 | 'Unable to write [_1]: [_2]' . $/, 414 | '$HOME/.clusterssh/clusters', 415 | $! 416 | ), 417 | ), 418 | ); 419 | } 420 | } 421 | 422 | if ( open( CONFIG, ">", "$ENV{HOME}/.clusterssh/config" ) ) { 423 | foreach ( sort( keys(%$self) ) ) { 424 | my $comment = ''; 425 | if ( grep /$_/, @ignore_default_config ) { 426 | $comment = '#'; 427 | } 428 | print CONFIG ${comment}, $_, '=', $self->{$_}, $/; 429 | } 430 | close(CONFIG); 431 | warn( 432 | $self->loc( 433 | 'Created new configuration file within [_1]' . $/, 434 | '$HOME/.clusterssh/' 435 | ) 436 | ); 437 | } 438 | else { 439 | croak( 440 | App::ClusterSSH::Exception::Config->throw( 441 | error => $self->loc( 442 | 'Unable to write default [_1]: [_2]' . $/, 443 | '$HOME/.clusterssh/config', $! 444 | ), 445 | ), 446 | ); 447 | } 448 | 449 | return $self; 450 | } 451 | 452 | # search given directories for the given file 453 | sub search_dirs { 454 | my ( $self, $file, @directories ) = @_; 455 | 456 | my $path; 457 | 458 | foreach my $dir (@directories) { 459 | $self->debug( 3, "Looking for $file in $dir" ); 460 | 461 | if ( -f $dir . '/' . $file && -x $dir . '/' . $file ) { 462 | $path = $dir . '/' . $file; 463 | $self->debug( 2, "Found at $path" ); 464 | last; 465 | } 466 | } 467 | 468 | return $path; 469 | } 470 | 471 | # could use File::Which for some of this but we also search a few other places 472 | # just in case $PATH isnt set up right 473 | sub find_binary { 474 | my ( $self, $binary ) = @_; 475 | 476 | if ( !$binary ) { 477 | croak( 478 | App::ClusterSSH::Exception::Config->throw( 479 | error => $self->loc('argument not provided') . $/, 480 | ), 481 | ); 482 | } 483 | 484 | $self->debug( 2, "Looking for $binary" ); 485 | 486 | # if not found, strip the path and look again 487 | if ( $binary =~ m!^/! ) { 488 | if ( -f $binary ) { 489 | $self->debug( 2, "Already have full path to in $binary" ); 490 | return $binary; 491 | } 492 | else { 493 | $self->debug( 2, "Full path for $binary incorrect; searching" ); 494 | $binary =~ s!^.*/!!; 495 | } 496 | } 497 | 498 | my $path; 499 | if ( !-x $binary || substr( $binary, 0, 1 ) ne '/' ) { 500 | $path = $self->search_dirs( $binary, split( /:/, $ENV{PATH} ) ); 501 | 502 | # if it is on $PATH then no need to qualitfy the path to it 503 | # keep it as it is 504 | if ($path) { 505 | return $binary; 506 | } 507 | else { 508 | $path = $self->search_dirs( 509 | $binary, qw! 510 | /bin 511 | /sbin 512 | /usr/sbin 513 | /usr/bin 514 | /usr/local/bin 515 | /usr/local/sbin 516 | /opt/local/bin 517 | /opt/local/sbin 518 | ! 519 | ); 520 | } 521 | 522 | } 523 | else { 524 | $self->debug( 2, "Already configured OK" ); 525 | $path = $binary; 526 | } 527 | if ( !$path || !-f $path || !-x $path ) { 528 | croak( 529 | App::ClusterSSH::Exception::Config->throw( 530 | error => $self->loc( 531 | '"[_1]" binary not found - please amend $PATH or the cssh config file' 532 | . $/, 533 | $binary 534 | ), 535 | ), 536 | ); 537 | } 538 | 539 | chomp($path); 540 | return $path; 541 | } 542 | 543 | sub dump { 544 | my ( $self, $no_exit, ) = @_; 545 | 546 | $self->debug( 3, 'Dumping config to STDOUT' ); 547 | print( '# Configuration dump produced by "cssh -d"', $/ ); 548 | 549 | foreach my $key ( sort keys %$self ) { 550 | my $comment = ''; 551 | if ( grep /$key/, @app_specific ) { 552 | next; 553 | } 554 | if ( grep /$key/, @ignore_default_config ) { 555 | $comment = '#'; 556 | } 557 | print $comment, $key, '=', $self->{$key}, $/; 558 | } 559 | 560 | $self->exit if ( !$no_exit ); 561 | } 562 | 563 | #use overload ( 564 | # q{""} => sub { 565 | # my ($self) = @_; 566 | # return $self->{hostname}; 567 | # }, 568 | # fallback => 1, 569 | #); 570 | 571 | 1; 572 | 573 | =head1 METHODS 574 | 575 | =over 4 576 | 577 | =item $host=ClusterSSH::Config->new ({ }) 578 | 579 | Create a new configuration object. 580 | 581 | =item $config->parse_config_file('<filename>'); 582 | 583 | Read in configuration from given filename 584 | 585 | =item $config->validate_args(); 586 | 587 | Validate and apply all configuration loaded at this point 588 | 589 | =item $path = $config->search_dirs('<name>', @seaarch_directories); 590 | 591 | Search the given directories for the name given. Return undef if not found. 592 | 593 | =item $path = $config->find_binary('<name>'); 594 | 595 | Locate the binary <name> and return the full path. Doesn't just search 596 | $PATH in case the environment isn't set up correctly 597 | 598 | =item $config->load_configs(@extra); 599 | 600 | Load up configuration from known locations (warn if .csshrc file found) and 601 | load in option files as necessary. 602 | 603 | =item $config->write_user_config_file(); 604 | 605 | Write out default $HOME/.clusterssh/config file (before option config files 606 | are loaded). 607 | 608 | =item $config->dump() 609 | 610 | Write currently defined configuration to STDOUT 611 | 612 | =back 613 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Helper.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::Helper; 5 | 6 | # ABSTRACT: ClusterSSH::Helper - Object representing helper script 7 | 8 | =head1 SYNOPSIS 9 | 10 | =head1 DESCRIPTION 11 | 12 | Object representing application configuration 13 | 14 | =cut 15 | 16 | use Carp; 17 | use Try::Tiny; 18 | 19 | use base qw/ App::ClusterSSH::Base /; 20 | 21 | sub new { 22 | my ( $class, %args ) = @_; 23 | 24 | my $self = $class->SUPER::new(%args); 25 | 26 | return $self; 27 | } 28 | 29 | sub script { 30 | my ( $self, $config ) = @_; 31 | 32 | if ( !defined $config 33 | || !ref $config 34 | || ref $config ne "App::ClusterSSH::Config" ) 35 | { 36 | croak( 37 | App::ClusterSSH::Exception::Helper->throw( 38 | error => 'No configuration provided or in wrong format', 39 | ), 40 | ); 41 | } 42 | 43 | foreach my $arg ( "comms", $config->{comms}, $config->{comms} . '_args', 44 | 'command', 'auto_close' ) 45 | { 46 | if ( !defined $config->{$arg} ) { 47 | croak( 48 | App::ClusterSSH::Exception::Helper->throw( 49 | error => "Config '$arg' not provided", 50 | ), 51 | ); 52 | } 53 | } 54 | 55 | my $command_pre = $config->{command_pre} || q{}; 56 | my $command_post = $config->{command_post} || q{}; 57 | my $comms = $config->{ $config->{comms} }; 58 | my $comms_args = $config->{ $config->{comms} . '_args' }; 59 | my $config_command = $config->{command}; 60 | my $autoclose = $config->{auto_close}; 61 | 62 | my $postcommand 63 | = $autoclose 64 | ? "echo Sleeping for $autoclose seconds; sleep $autoclose" 65 | : "echo Press RETURN to continue; read IGNORE" 66 | ; # : "sleep $autoclose"; 67 | 68 | my $script = <<" HERE"; 69 | my \$pipe=shift; 70 | my \$svr=shift; 71 | my \$user=shift; 72 | my \$port=shift; 73 | my \$mstr=shift; 74 | my \$command="$command_pre $comms $comms_args "; 75 | open(PIPE, ">", \$pipe) or die("Failed to open pipe: \$!\\n"); 76 | print PIPE "\$\$:\$ENV{WINDOWID}" 77 | or die("Failed to write to pipe: $!\\n"); 78 | close(PIPE) or die("Failed to close pipe: $!\\n"); 79 | if(\$svr =~ m/==\$/) 80 | { 81 | \$svr =~ s/==\$//; 82 | warn("\\nWARNING: failed to resolve IP address for \$svr.\\n\\n" 83 | ); 84 | sleep 5; 85 | } 86 | if(\$mstr) { 87 | unless("$comms" ne "console") { 88 | \$mstr = \$mstr ? "-M \$mstr " : ""; 89 | \$command .= \$mstr; 90 | } 91 | } 92 | if(\$user) { 93 | unless("$comms" eq "telnet") { 94 | \$user = \$user ? "-l \$user " : ""; 95 | \$command .= \$user; 96 | } 97 | } 98 | if("$comms" eq "telnet") { 99 | \$command .= "\$svr \$port"; 100 | } else { 101 | if (\$port) { 102 | \$command .= "-p \$port \$svr"; 103 | } else { 104 | \$command .= "\$svr"; 105 | } 106 | } 107 | if("$config_command") { 108 | \$command .= " \\\"$config_command\\\""; 109 | } 110 | \$command .= "$command_post"; 111 | \$command .= " ; $postcommand"; 112 | # provide some info for debugging purposes 113 | warn("Running: \$command\\n"); 114 | exec(\$command); 115 | HERE 116 | 117 | $self->debug( 4, $script ); 118 | $self->debug( 2, 'Helper script done' ); 119 | 120 | return $script; 121 | } 122 | 123 | #use overload ( 124 | # q{""} => sub { 125 | # my ($self) = @_; 126 | # return $self->{hostname}; 127 | # }, 128 | # fallback => 1, 129 | #); 130 | 131 | 1; 132 | 133 | =head1 METHODS 134 | 135 | =over 4 136 | 137 | =item $host=ClusterSSH::Helper->new ({ }) 138 | 139 | Create a new helper object. 140 | 141 | =item $host=ClusterSSH::Helper->script ({ }) 142 | 143 | Return the helper script 144 | 145 | =back 146 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Host.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::Host; 5 | 6 | # ABSTRACT: ClusterSSH::Host - Object representing a host. 7 | 8 | =head1 SYNOPSIS 9 | 10 | use ClusterSSH::Host; 11 | 12 | my $host = ClusterSSH::Host->new({ 13 | hostname => 'hostname', 14 | }); 15 | my $host = ClusterSSH::Host->parse_host_string('username@hostname:1234'); 16 | 17 | =head1 DESCRIPTION 18 | 19 | Object representing a host. Include details to contact the host such as 20 | hostname/ipaddress, username and port. 21 | 22 | =cut 23 | 24 | use Carp; 25 | use Net::hostent; 26 | 27 | use base qw/ App::ClusterSSH::Base /; 28 | 29 | our %ssh_hostname_for; 30 | our %ssh_configs_read; 31 | 32 | sub new { 33 | my ( $class, %args ) = @_; 34 | 35 | if ( !$args{hostname} ) { 36 | croak( 37 | App::ClusterSSH::Exception->throw( 38 | error => $class->loc('hostname is undefined') 39 | ) 40 | ); 41 | } 42 | 43 | # remove any keys undef values - must be a better way... 44 | foreach my $remove (qw/ port username geometry /) { 45 | if ( !$args{$remove} && grep {/^$remove$/} keys(%args) ) { 46 | delete( $args{$remove} ); 47 | } 48 | } 49 | 50 | my $self 51 | = $class->SUPER::new( ssh_config => "$ENV{HOME}/.ssh/config", %args ); 52 | 53 | # load in ssh hostname for later use 54 | if ( !%ssh_hostname_for || !$ssh_configs_read{ $self->{ssh_config} } ) { 55 | $self->read_ssh_file( $self->{ssh_config} ); 56 | 57 | $self->debug( 5, 'Have the following ssh hostnames' ); 58 | $self->debug( 5, ' "', $_, '"' ) 59 | foreach ( sort keys %ssh_hostname_for ); 60 | } 61 | 62 | return $self; 63 | } 64 | 65 | sub read_ssh_file($$) { 66 | my ($self) = shift; 67 | my ($filename) = glob(shift); 68 | $self->debug( 3, 'Reading SSH file: ', $filename ); 69 | 70 | $ssh_configs_read{$filename} = 1; 71 | 72 | if ( open( my $ssh_config_fh, '<', $filename ) ) { 73 | while ( my $line = <$ssh_config_fh> ) { 74 | chomp $line; 75 | 76 | if ( $line =~ /^\s*include\s+(.+)/i ) { 77 | $self->read_ssh_file($1); 78 | next; 79 | } 80 | 81 | next unless ( $line =~ m/^\s*host\s+(.*)/i ); 82 | 83 | # account for multiple declarations of hosts 84 | $ssh_hostname_for{$_} = 1 foreach ( split( /\s+/, $1 ) ); 85 | } 86 | close($ssh_config_fh); 87 | } 88 | else { 89 | $self->debug( 3, 'Unable to read ', $filename, ': ', $!, $/ ); 90 | } 91 | } 92 | 93 | sub get_hostname { 94 | my ($self) = @_; 95 | return $self->{hostname}; 96 | } 97 | 98 | sub get_username { 99 | my ($self) = @_; 100 | return $self->{username} || q{}; 101 | } 102 | 103 | sub get_type { 104 | my ($self) = @_; 105 | if ( $self->check_ssh_hostname ) { 106 | return 'ssh_alias'; 107 | } 108 | return $self->{type} || q{}; 109 | } 110 | 111 | sub get_geometry { 112 | my ($self) = @_; 113 | return $self->{geometry} || q{}; 114 | } 115 | 116 | sub set_username { 117 | my ( $self, $new_username ) = @_; 118 | $self->{username} = $new_username; 119 | return $self; 120 | } 121 | 122 | sub get_port { 123 | my ($self) = @_; 124 | return $self->{port} || q{}; 125 | } 126 | 127 | sub set_port { 128 | my ( $self, $new_port ) = @_; 129 | $self->{port} = $new_port; 130 | return $self; 131 | } 132 | 133 | sub set_type { 134 | my ( $self, $type ) = @_; 135 | $self->{type} = $type; 136 | return $self; 137 | } 138 | 139 | sub set_geometry { 140 | my ( $self, $geometry ) = @_; 141 | $self->{geometry} = $geometry; 142 | return $self; 143 | } 144 | 145 | sub get_master { 146 | my ($self) = @_; 147 | return $self->{master} || q{}; 148 | } 149 | 150 | sub set_master { 151 | my ( $self, $new_master ) = @_; 152 | $self->{master} = $new_master; 153 | return $self; 154 | } 155 | 156 | sub get_realname { 157 | my ($self) = @_; 158 | 159 | if ( !$self->{realname} ) { 160 | if ( $self->get_type eq 'ssh_alias' ) { 161 | $self->{realname} = $self->{hostname}; 162 | } 163 | else { 164 | my $gethost_obj = gethostbyname( $self->{hostname} ); 165 | 166 | $self->{realname} 167 | = defined($gethost_obj) 168 | ? $gethost_obj->name() 169 | : $self->{hostname}; 170 | } 171 | } 172 | return $self->{realname}; 173 | } 174 | 175 | sub parse_host_string { 176 | my ( $self, $host_string ) = @_; 177 | my $parse_string = $host_string; 178 | 179 | $self->debug( 5, $self->loc( 'host_string=" [_1] "', $host_string ), ); 180 | 181 | # check for bracketed IPv6 addresses 182 | if ($host_string =~ m{ 183 | \A 184 | (?:(.*?)@)? # username@ (optional) 185 | \[([\w:]*)\] # [<sequence of chars>] 186 | (?::(\d+))? # :port (optional) 187 | (?:=(\d+\D\d+\D\d+\D\d))? # =geometry (optional) 188 | \z 189 | }xms 190 | ) 191 | { 192 | $self->debug( 193 | 5, 194 | $self->loc( 195 | 'bracketed IPv6: u=[_1] h=[_2] p=[_3] g=[_4]', 196 | $1, $2, $3, $4 197 | ), 198 | ); 199 | return __PACKAGE__->new( 200 | parse_string => $parse_string, 201 | username => $1, 202 | hostname => $2, 203 | port => $3, 204 | geometry => $4, 205 | type => 'ipv6', 206 | ); 207 | } 208 | 209 | # check for standard IPv4 host.domain/IP address 210 | if ($host_string =~ m{ 211 | \A 212 | (?:(.*?)@)? # username@ (optional) 213 | ([\w\.-]*) # hostname[.domain[.domain] | 123.123.123.123 214 | (?::(\d+))? # :port (optional) 215 | (?:=(\d+\D\d+\D\d+\D\d+))? # =geometry (optional) 216 | \z 217 | }xms 218 | ) 219 | { 220 | $self->debug( 221 | 5, 222 | $self->loc( 223 | 'std IPv4: u=[_1] h=[_2] p=[_3] g=[_4]', 224 | $1, $2, $3, $4 225 | ), 226 | ); 227 | return __PACKAGE__->new( 228 | parse_string => $parse_string, 229 | username => $1, 230 | hostname => $2, 231 | port => $3, 232 | geometry => $4, 233 | type => 'ipv4', 234 | ); 235 | } 236 | 237 | # Check for unbracketed IPv6 addresses as best we can... 238 | my $username = q{}; 239 | my $geometry = q{}; 240 | my $port = q{}; 241 | 242 | # first, see if there is a username to grab 243 | if ( $host_string =~ s/\A(?:(.*?)@)// ) { 244 | 245 | # catch where @ is in host_string but no text before it 246 | $username = $1; 247 | } 248 | 249 | # check for any geometry settings 250 | if ( $host_string =~ s/(?:=(.*?)$)// ) { 251 | $geometry = $1; 252 | } 253 | 254 | # Check for a '/nnnn' port definition 255 | if ( $host_string =~ s!(?:/(\d+)$)!! ) { 256 | $port = $1; 257 | } 258 | 259 | # use number of colons as a possible indicator 260 | my $colon_count = $host_string =~ tr/://; 261 | 262 | # if there are 7 colons assume its a full IPv6 address 263 | # if its 8 then assumed full IPv6 address with a port 264 | # also catch localhost address here 265 | if ( $colon_count == 7 || $colon_count == 8 || $host_string eq '::1' ) { 266 | if ( $colon_count == 8 ) { 267 | $host_string =~ s/(?::(\d+?))$//; 268 | $port = $1; 269 | } 270 | $self->debug( 271 | 5, 272 | $self->loc( 273 | 'IPv6: u=[_1] h=[_2] p=[_3] g=[_4]', 274 | $username, $host_string, $port, $geometry, 275 | ), 276 | ); 277 | return __PACKAGE__->new( 278 | parse_string => $parse_string, 279 | username => $username, 280 | hostname => $host_string, 281 | port => $port, 282 | geometry => $geometry, 283 | type => 'ipv6', 284 | ); 285 | } 286 | if ( $colon_count > 1 287 | && $colon_count < 8 ) 288 | { 289 | warn 'Ambiguous host string: "', $host_string, '"', $/; 290 | warn 'Assuming you meant "[', $host_string, ']"?', $/; 291 | 292 | $self->debug( 293 | 5, 294 | $self->loc( 295 | 'Ambiguous IPv6 u=[_1] h=[_2] p=[_3] g=[_4]', 296 | $username, $host_string, $port, $geometry, 297 | ) 298 | ); 299 | 300 | return __PACKAGE__->new( 301 | parse_string => $parse_string, 302 | username => $username, 303 | hostname => $host_string, 304 | port => $port, 305 | geometry => $geometry, 306 | type => 'ipv6', 307 | ); 308 | } 309 | 310 | # if we got this far, we didnt parse the host_string properly 311 | croak( 312 | App::ClusterSSH::Exception->throw( 313 | error => $self->loc( 314 | 'Unable to parse hostname from "[_1]"', $host_string 315 | ) 316 | ) 317 | ); 318 | } 319 | 320 | sub check_ssh_hostname { 321 | my ( $self, ) = @_; 322 | 323 | $self->debug( 4, 'Checking ssh hosts for hostname ', 324 | $self->get_hostname ); 325 | 326 | if ( $ssh_hostname_for{ $self->get_hostname } ) { 327 | $self->debug( 5, 'Found' ); 328 | return 1; 329 | } 330 | else { 331 | $self->debug( 5, 'Not found' ); 332 | return 0; 333 | } 334 | } 335 | 336 | use overload ( 337 | q{""} => sub { 338 | my ($self) = @_; 339 | return $self->{hostname}; 340 | }, 341 | fallback => 1, 342 | ); 343 | 344 | 1; 345 | 346 | =head1 METHODS 347 | 348 | =over 4 349 | 350 | =item $host=ClusterSSH::Host->new ({ hostname => 'hostname' }) 351 | 352 | Create a new host object. 'hostname' is a required arg, 'username' and 353 | 'port' are optional. Raises exception if an error occurs. 354 | 355 | =item $host->get_hostname 356 | 357 | =item $host->get_username 358 | 359 | =item $host->get_port 360 | 361 | =item $host->get_master 362 | 363 | =item $host->get_geometry 364 | 365 | =item $host->get_type 366 | 367 | Return specific details about the host 368 | 369 | =item $host->set_username 370 | 371 | =item $host->set_port 372 | 373 | =item $host->set_master 374 | 375 | =item $host->set_geometry 376 | 377 | =item $host->set_type 378 | 379 | Set specific details about the host after its been created. 380 | 381 | =item get_realname 382 | 383 | If the server name provided is not an IP address (either IPv4 or IPv6) 384 | attempt to resolve it and return the discovered names. 385 | 386 | =item get_givenname 387 | 388 | Alias to get_hostname, for use when C< get_realname > might return something 389 | different 390 | 391 | =item parse_host_string 392 | 393 | Given a host string, returns a host object. Parses hosts such as 394 | 395 | =item check_ssh_hostname 396 | 397 | Check the objects hostname to see whether or not it may be configured within 398 | the users F< $HOME/.ssh/config > configuration file 399 | 400 | =item read_ssh_file 401 | 402 | Method to ease reading in ssh configuration files. Used for grabbing 403 | hostnames for validation when used in clusters 404 | 405 | =over 4 406 | 407 | =item host 408 | 409 | =item 192.168.0.1 410 | 411 | =item user@host 412 | 413 | =item user@192.168.0.1 414 | 415 | =item host:port 416 | 417 | =item [1234:1234:1234::4567]:port 418 | 419 | =item 1234:1234:1234::4567 420 | 421 | =back 422 | 423 | and so on. Cope with IPv4 and IPv6 addresses - raises a warning if the 424 | IPv6 address is ambiguous (i.e. in the last example, is the 4567 part of 425 | the IPv6 address or a port definition?) and assumes it is part of address. 426 | Use brackets to avoid seeing warning. 427 | 428 | =back 429 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/L10N.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::L10N; 5 | 6 | # ABSTRACT: ClusterSSH::L10N - Base translations module 7 | 8 | =head1 SYNOPSIS 9 | 10 | use ClusterSSH::L10N; 11 | my $lang = ClusterSSH::L10N->get_handle('en'); 12 | $lang->maketext('text to localise with args [_1]', $arg1); 13 | 14 | =head1 DESCRIPTION 15 | 16 | L<Locale::Maketext> based translation module for ClusterSSH. See 17 | L<Locale::Maketext> for more information and usage. 18 | 19 | NOTE: the default language of this module is English. 20 | 21 | =head1 METHODS 22 | 23 | See Locale::Maketext - there are currently no extra methods in this module. 24 | 25 | =cut 26 | 27 | use Locale::Maketext 1.01; 28 | use base qw(Locale::Maketext); 29 | 30 | # This projects primary language is English 31 | 32 | our %Lexicon = ( '_AUTO' => 1, ); 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/L10N/en.pm: -------------------------------------------------------------------------------- 1 | package App::ClusterSSH::L10N::en; 2 | 3 | # ABSTRACT: App::ClusterSSH::L10N::en - Base English translations module 4 | 5 | =head1 SYNOPSIS 6 | 7 | use App::ClusterSSH::L10N; 8 | my $lang = ClusterSSH::L10N->get_handle('en'); 9 | $lang->maketext('text to localise with args [_1]', $arg1); 10 | 11 | =head1 DESCRIPTION 12 | 13 | L<Locale::Maketext> based translation module for ClusterSSH. See 14 | L<Locale::Maketext> for more information and usage. 15 | 16 | =cut 17 | 18 | use base 'App::ClusterSSH::L10N'; 19 | 20 | %Lexicon = ( '_AUTO' => 1, ); 21 | 22 | 1; 23 | 24 | =head1 METHODS 25 | 26 | No method are exported. See L<Locale::Maketext>. 27 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Range.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::Range; 5 | 6 | # ABSTRACT: Expand ranges such as {0..1} as well as other bsd_glob specs 7 | 8 | =head1 SYNOPSIS 9 | 10 | use App::ClusterSSH::Range; 11 | my $range=App::ClusterSSH::Range->new(); 12 | my @list = $range->expand('range{0..5}'); 13 | 14 | =head1 DESCRIPTION 15 | 16 | Perform string expansion looking for ranges before then finishing off 17 | using C<File::Glob::bsd_glob>. 18 | 19 | =cut 20 | 21 | use File::Glob; 22 | 23 | =head1 METHODS 24 | 25 | =over 4 26 | 27 | =item $range = App::ClusterSSH::Range->new(); 28 | 29 | Create a new object to perform range processing 30 | 31 | =cut 32 | 33 | sub new { 34 | my ( $class, %args ) = @_; 35 | my $self = {%args}; 36 | return bless $self, $class; 37 | } 38 | 39 | =item @expanded = $range->expand(@strings); 40 | 41 | Expand the given strings. Ranges are checked for and processed. The 42 | resulting string is then put through File::Glob::bsd_glob before being returned. 43 | 44 | Ranges are of the form: 45 | 46 | base{start..stop} 47 | a{0..3} => a0 a1 a2 a3 48 | b{4..6,9,12..14} => b4 b5 b6 b9 b12 b13 b14 49 | 50 | =back 51 | 52 | =cut 53 | 54 | sub expand { 55 | my ( $self, @items ) = @_; 56 | 57 | my $range_regexp = qr/[\w-]*:?\{[\w\.,]+\}/; 58 | my @newlist; 59 | foreach my $item (@items) { 60 | if ( $item !~ m/$range_regexp/ ) { 61 | push( @newlist, $item ); 62 | next; 63 | } 64 | 65 | my ( $base, $spec ) = $item =~ m/^(.*?\{(.*?)\}.*?)$/; 66 | 67 | for my $section ( split( /,/, $spec ) ) { 68 | my ( $start, $end ); 69 | 70 | if ( $section =~ m/\.\./ ) { 71 | ( $start, $end ) = split( /\.\./, $section, 2 ); 72 | } 73 | 74 | $start = $section if ( !defined($start) ); 75 | $end = $start if ( !defined($end) ); 76 | 77 | foreach my $number ( $start .. $end ) { 78 | ( my $changed = $base ) =~ s/\{$spec\}/$number/; 79 | push( @newlist, $changed ); 80 | } 81 | } 82 | } 83 | 84 | my @text = map { File::Glob::bsd_glob($_) } @newlist; 85 | 86 | return wantarray ? @text : "@text"; 87 | } 88 | 89 | 1; 90 | -------------------------------------------------------------------------------- /lib/App/ClusterSSH/Window.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package App::ClusterSSH::Window; 5 | 6 | # ABSTRACT: App::ClusterSSH::Window - Base obejct for different types of window module 7 | 8 | =head1 DESCRIPTION 9 | 10 | Base object to allow for configuring and using different types of windows libraries 11 | 12 | =cut 13 | 14 | =head1 METHODS 15 | 16 | =over 4 17 | 18 | =cut 19 | 20 | use Carp; 21 | 22 | use base qw/ App::ClusterSSH::Base /; 23 | 24 | # Module to contain window generic code and pull in specific code from 25 | # an appropriate module 26 | 27 | sub import { 28 | my ($class) = @_; 29 | 30 | # If we are building or in test here, just exit 31 | # as the build servers will not have Tk installed 32 | if ( $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING} ) { 33 | print STDERR 34 | "skipping initialisation; AUTHOR_TESTING or RELEASE_TESTING are set\n"; 35 | return; 36 | } 37 | 38 | # Find what windows module we should be using and just overlay it into 39 | # this object 40 | my $package_name = __PACKAGE__ . '::Tk'; 41 | ( my $package_path = $package_name ) =~ s{::}{/}g; 42 | require "$package_path.pm"; 43 | $package_name->import(); 44 | 45 | { 46 | no strict 'refs'; 47 | push @{ __PACKAGE__ . '::ISA' }, $package_name; 48 | } 49 | } 50 | 51 | my %servers; 52 | 53 | =item $obj = App::ClusterSSH::Window->new({}); 54 | 55 | Creates object 56 | 57 | =back 58 | 59 | =cut 60 | 61 | sub new { 62 | my ( $class, %args ) = @_; 63 | my $self = $class->SUPER::new(%args); 64 | 65 | return $self; 66 | } 67 | 68 | 1; 69 | -------------------------------------------------------------------------------- /t/00-load.t: -------------------------------------------------------------------------------- 1 | use FindBin; 2 | use lib $FindBin::Bin. '/../lib'; 3 | 4 | use Test::More tests => 1; 5 | 6 | BEGIN { 7 | use_ok('App::ClusterSSH'); 8 | } 9 | 10 | note("Testing App::ClusterSSH $App::ClusterSSH::VERSION, Perl $], $^X"); 11 | -------------------------------------------------------------------------------- /t/01l10n.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use FindBin qw($Bin); 5 | use lib "$Bin/../lib"; 6 | 7 | use Test::More tests => 2; 8 | use Test::Trap; 9 | 10 | BEGIN { use_ok( 'App::ClusterSSH::L10N', ) } 11 | 12 | my $handle; 13 | 14 | $handle = App::ClusterSSH::L10N->get_handle(); 15 | isa_ok( $handle, 'App::ClusterSSH::L10N' ); 16 | -------------------------------------------------------------------------------- /t/02base.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use FindBin qw($Bin); 5 | use lib "$Bin/../lib"; 6 | 7 | use Test::More; 8 | use Test::Trap; 9 | 10 | BEGIN { use_ok('App::ClusterSSH::Base') } 11 | 12 | # force default language for tests 13 | App::ClusterSSH::Base->set_lang('en'); 14 | 15 | my $base; 16 | 17 | $base = App::ClusterSSH::Base->new(); 18 | isa_ok( $base, 'App::ClusterSSH::Base' ); 19 | 20 | diag('testing output') if ( $ENV{TEST_VERBOSE} ); 21 | trap { 22 | $base->stdout_output('testing'); 23 | }; 24 | is( $trap->leaveby, 'return', 'returned ok' ); 25 | is( $trap->die, undef, 'returned ok' ); 26 | is( $trap->stderr, '', 'Expecting no STDERR' ); 27 | is( $trap->stdout =~ tr/\n//, 1, 'got correct number of print lines' ); 28 | like( $trap->stdout, qr/\Atesting\n\Z/xsm, 29 | 'checking for expected print output' ); 30 | 31 | diag('Testing debug output') if ( $ENV{TEST_VERBOSE} ); 32 | 33 | for my $level ( 0 .. 9 ) { 34 | $base->set_debug_level($level); 35 | is( $base->debug_level(), $level, 'debug level is correct' ); 36 | 37 | trap { 38 | for my $log_level ( 0 .. 9 ) { 39 | $base->debug( $log_level, 'test' ); 40 | } 41 | }; 42 | 43 | is( $trap->leaveby, 'return', 'returned ok' ); 44 | is( $trap->die, undef, 'returned ok' ); 45 | is( $trap->stderr, '', 'Expecting no STDERR' ); 46 | is( $trap->stdout =~ tr/\n//, 47 | $level + 1, 'got correct number of debug lines' ); 48 | like( $trap->stdout, qr/(?:test\n){$level}/xsm, 49 | 'checking for expected debug output' ); 50 | } 51 | 52 | my $level; 53 | trap { 54 | $level = $base->set_debug_level(); 55 | }; 56 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 57 | 'Caught exception object OK' ); 58 | is( $trap->leaveby, 'die', 'returned ok' ); 59 | is( $trap->stderr, '', 'Expecting no STDERR' ); 60 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 61 | like( $trap->die, qr/^Debug level not provided/, 'Got correct croak text' ); 62 | 63 | $base->set_debug_level(10); 64 | is( $base->debug_level(), 9, 'checking debug_level reset to 9' ); 65 | 66 | $base = undef; 67 | trap { 68 | $base = App::ClusterSSH::Base->new( debug => 6, ); 69 | }; 70 | isa_ok( $base, 'App::ClusterSSH::Base' ); 71 | is( $trap->leaveby, 'return', 'returned ok' ); 72 | is( $trap->die, undef, 'returned ok' ); 73 | is( $trap->stderr, '', 'Expecting no STDERR' ); 74 | is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); 75 | like( 76 | $trap->stdout, 77 | qr/^Setting\slanguage\sto\s"en"/xsm, 78 | 'got expected new() output' 79 | ); 80 | 81 | $base = undef; 82 | trap { 83 | $base = App::ClusterSSH::Base->new( debug => 6, lang => 'en' ); 84 | }; 85 | isa_ok( $base, 'App::ClusterSSH::Base' ); 86 | is( $trap->leaveby, 'return', 'returned ok' ); 87 | is( $trap->die, undef, 'returned ok' ); 88 | is( $trap->stderr, '', 'Expecting no STDERR' ); 89 | is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); 90 | like( 91 | $trap->stdout, 92 | qr/^Setting\slanguage\sto\s"en"/xsm, 93 | 'got expected new() output' 94 | ); 95 | 96 | $base = undef; 97 | trap { 98 | $base = App::ClusterSSH::Base->new( debug => 6, lang => 'rubbish' ); 99 | }; 100 | isa_ok( $base, 'App::ClusterSSH::Base' ); 101 | is( $trap->leaveby, 'return', 'returned ok' ); 102 | is( $trap->die, undef, 'returned ok' ); 103 | is( $trap->stderr, '', 'Expecting no STDERR' ); 104 | is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); 105 | like( 106 | $trap->stdout, 107 | qr/^Setting\slanguage\sto\s"rubbish"/xsm, 108 | 'got expected new() output' 109 | ); 110 | 111 | $base = undef; 112 | my $get_config; 113 | trap { 114 | $base = App::ClusterSSH::Base->new( debug => 7, ); 115 | }; 116 | isa_ok( $base, 'App::ClusterSSH::Base' ); 117 | is( $trap->leaveby, 'return', 'returned ok' ); 118 | is( $trap->die, undef, 'returned ok' ); 119 | is( $trap->stderr, '', 'Expecting no STDERR' ); 120 | is( $trap->stdout =~ tr/\n//, 3, 'got new() debug output lines' ); 121 | like( 122 | $trap->stdout, 123 | qr/^Setting\slanguage\sto\s"en".Arguments\sto\sApp::ClusterSSH::Base->new.*debug\s=>\s7,$/xsm, 124 | 'got expected new() output' 125 | ); 126 | 127 | trap { 128 | $get_config = $base->config(); 129 | }; 130 | $trap->quiet("No issus with config call"); 131 | is( $get_config, undef, "config set undef as expected" ); 132 | 133 | # config tests 134 | $base = undef; 135 | my $object; 136 | trap { 137 | $base = App::ClusterSSH::Base->new( debug => 3, ); 138 | }; 139 | isa_ok( $base, 'App::ClusterSSH::Base' ); 140 | is( $trap->leaveby, 'return', 'returned ok' ); 141 | is( $trap->die, undef, 'returned ok' ); 142 | is( $trap->stderr, '', 'Expecting no STDERR' ); 143 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 144 | 145 | $base = undef; 146 | trap { 147 | $base = App::ClusterSSH::Base->new( debug => 3, parent => 'guardian' ); 148 | }; 149 | isa_ok( $base, 'App::ClusterSSH::Base' ); 150 | is( $trap->leaveby, 'return', 'returned ok' ); 151 | is( $trap->die, undef, 'returned ok' ); 152 | is( $trap->stderr, '', 'Expecting no STDERR' ); 153 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 154 | is( $base->parent, 'guardian', 'Expecting no STDOUT' ); 155 | 156 | trap { 157 | $get_config = $base->config(); 158 | }; 159 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 160 | 'Caught exception object OK' ); 161 | is( $trap->leaveby, 'die', 'died ok' ); 162 | like( $trap->die, qr/^config has not yet been set/, 163 | 'Got correct croak text' ); 164 | is( $trap->stderr, '', 'Expecting no STDERR' ); 165 | is( $trap->stdout, '', 'Expecting not STDOUT' ); 166 | is( $get_config, undef, 'config left empty' ); 167 | 168 | trap { 169 | $object = $base->set_config(); 170 | }; 171 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 172 | 'Caught exception object OK' ); 173 | is( $trap->leaveby, 'die', 'died ok' ); 174 | like( $trap->die, qr/^passed config is empty/, 'Got correct croak text' ); 175 | is( $trap->stderr, '', 'Expecting no STDERR' ); 176 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 177 | 178 | trap { 179 | $object = $base->set_config('set to scalar'); 180 | }; 181 | is( $trap->leaveby, 'return', 'returned ok' ); 182 | is( $trap->die, undef, 'config set ok' ); 183 | is( $trap->stderr, '', 'Expecting no STDERR' ); 184 | like( 185 | $trap->stdout, 186 | qr/^Setting\sapp\sconfiguration/xsm, 187 | 'Got expected STDOUT' 188 | ); 189 | isa_ok( $object, 'App::ClusterSSH::Base' ); 190 | 191 | trap { 192 | $get_config = $base->config(); 193 | }; 194 | is( $trap->leaveby, 'return', 'returned ok' ); 195 | is( $trap->die, undef, 'returned ok' ); 196 | is( $trap->stderr, '', 'Expecting no STDERR' ); 197 | is( $trap->stdout, '', 'Expecting not STDOUT' ); 198 | is( $get_config, 'set to scalar', 'config set as expected' ); 199 | 200 | trap { 201 | $object = $base->set_config('set to another scalar'); 202 | }; 203 | is( $trap->leaveby, 'die', 'died ok' ); 204 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 205 | 'Caught exception object OK' ); 206 | like( 207 | $trap->die, 208 | qr/^config\shas\salready\sbeen\sset/, 209 | 'config cannot be reset' 210 | ); 211 | is( $trap->stderr, '', 'Expecting no STDERR' ); 212 | is( $trap->stdout, '', 'Got expected STDOUT' ); 213 | 214 | trap { 215 | $object = $base->set_config(); 216 | }; 217 | is( $trap->leaveby, 'die', 'died ok' ); 218 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 219 | 'Caught exception object OK' ); 220 | like( 221 | $trap->die, 222 | qr/^config\shas\salready\sbeen\sset/, 223 | 'config cannot be reset' 224 | ); 225 | is( $trap->stderr, '', 'Expecting no STDERR' ); 226 | is( $trap->stdout, '', 'Got expected STDOUT' ); 227 | 228 | # basic checks - validity of config is tested elsewhere 229 | my %config; 230 | trap { 231 | %config = $object->load_file; 232 | }; 233 | is( $trap->leaveby, 'die', 'died ok' ); 234 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 235 | 'Caught exception object OK' ); 236 | is( $trap->die, 237 | q{"filename" arg not passed}, 238 | 'missing filename arg die message' 239 | ); 240 | is( $trap->stderr, '', 'Expecting no STDERR' ); 241 | is( $trap->stdout, '', 'Got expected STDOUT' ); 242 | 243 | trap { 244 | %config = $object->load_file( filename => $Bin . '/15config.t.file1' ); 245 | }; 246 | is( $trap->leaveby, 'die', 'died ok' ); 247 | isa_ok( $trap->die, 'App::ClusterSSH::Exception', 248 | 'Caught exception object OK' ); 249 | is( $trap->die, q{"type" arg not passed}, 'missing type arg die message' ); 250 | is( $trap->stderr, '', 'Expecting no STDERR' ); 251 | 252 | my $get_options; 253 | 254 | $base = undef; 255 | trap { 256 | $base = App::ClusterSSH::Base->new( debug => 3 ); 257 | }; 258 | isa_ok( $base, 'App::ClusterSSH::Base' ); 259 | is( $trap->leaveby, 'return', 'returned ok' ); 260 | is( $trap->die, undef, 'returned ok' ); 261 | is( $trap->stderr, '', 'Expecting no STDERR' ); 262 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 263 | is( $base->parent, undef, 'Expecting no parent set' ); 264 | 265 | trap { 266 | $get_options = $base->options(); 267 | }; 268 | $trap->quiet("No extra output"); 269 | is( $get_options, undef, "options call correctly unset" ); 270 | 271 | $base = undef; 272 | trap { 273 | $base = App::ClusterSSH::Base->new( debug => 3, parent => 'guardian' ); 274 | }; 275 | isa_ok( $base, 'App::ClusterSSH::Base' ); 276 | is( $trap->leaveby, 'return', 'returned ok' ); 277 | is( $trap->die, undef, 'returned ok' ); 278 | is( $trap->stderr, '', 'Expecting no STDERR' ); 279 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 280 | is( $base->parent, 'guardian', 'Expecting no STDOUT' ); 281 | 282 | trap { 283 | $get_options = $base->options(); 284 | }; 285 | $trap->quiet("No extra output"); 286 | is( $get_options, undef, "options call correctly unset" ); 287 | 288 | $base = undef; 289 | trap { 290 | $base = App::ClusterSSH::Base->new( 291 | debug => 3, 292 | parent => { config => 'set', options => 'set' } 293 | ); 294 | }; 295 | isa_ok( $base, 'App::ClusterSSH::Base' ); 296 | is( $trap->leaveby, 'return', 'returned ok' ); 297 | is( $trap->die, undef, 'returned ok' ); 298 | is( $trap->stderr, '', 'Expecting no STDERR' ); 299 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 300 | is( ref( $base->parent ), 'HASH', 'Expecting no STDOUT' ); 301 | is( $base->parent->{config}, 'set', 'Expecting no STDOUT' ); 302 | 303 | trap { 304 | $get_options = $base->options(); 305 | }; 306 | is( ref($get_options), '', "options call correctly set" ); 307 | is( $get_options, 'set', "options call hash value correctly set" ); 308 | $trap->quiet("No extra output"); 309 | 310 | my $sort; 311 | trap { 312 | $sort = $base->sort; 313 | }; 314 | $trap->quiet("No errors getting 'sort'"); 315 | 316 | # NOTE: trap doesnt like passing code refs, so recreate here 317 | $sort = $base->sort; 318 | is( ref($sort), 'CODE', "got results from sort" ); 319 | my @sorted = $sort->( 4, 8, 1, 5, 3 ); 320 | my @expected = ( 1, 3, 4, 5, 8 ); 321 | is_deeply( \@sorted, \@expected, "simple sort results okay" ); 322 | 323 | $base = undef; 324 | trap { 325 | $base = App::ClusterSSH::Base->new( 326 | debug => 3, 327 | parent => { config => { use_natural_sort => 1 }, options => 'set' } 328 | ); 329 | }; 330 | isa_ok( $base, 'App::ClusterSSH::Base' ); 331 | is( $trap->leaveby, 'return', 'returned ok' ); 332 | is( $trap->die, undef, 'returned ok' ); 333 | is( $trap->stderr, '', 'Expecting no STDERR' ); 334 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 335 | 336 | trap { 337 | $sort = $base->sort; 338 | }; 339 | 340 | # May get an error here if Sort::Naturally is not installed 341 | # $trap->quiet("No errors getting 'sort'"); 342 | is( $trap->leaveby, 'return', 'returned ok' ); 343 | is( $trap->die, undef, 'returned ok' ); 344 | is( ref($sort), 'CODE', "got results from sort" ); 345 | @sorted = $sort->( 4, 8, 1, 5, 3 ); 346 | @expected = ( 1, 3, 4, 5, 8 ); 347 | is_deeply( \@sorted, \@expected, "simple sort results okay" ); 348 | 349 | done_testing(); 350 | -------------------------------------------------------------------------------- /t/05getopts.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # Force use of English in tests for the moment, for those users that 5 | # have a different locale set, since errors are hardcoded below 6 | use POSIX qw(setlocale locale_h); 7 | setlocale( LC_ALL, "C" ); 8 | 9 | package Test::ClusterSSH::Mock; 10 | 11 | # generate purpose object used to simplfy testing 12 | 13 | sub new { 14 | my ( $class, %args ) = @_; 15 | my $config = { 16 | comms => 'testing', 17 | key_addhost => 'x', 18 | key_clientname => 'x', 19 | key_localname => 'x', 20 | key_quit => 'x', 21 | key_retilehosts => 'x', 22 | key_username => 'x', 23 | %args 24 | }; 25 | return bless $config, $class; 26 | } 27 | 28 | sub parent { 29 | my ($self) = @_; 30 | return $self; 31 | } 32 | 33 | sub VERSION { 34 | my ($self) = @_; 35 | return 'TESTING'; 36 | } 37 | 38 | sub config { 39 | my ($self) = @_; 40 | return $self; 41 | } 42 | 43 | sub load_configs { 44 | my ($self) = @_; 45 | return $self; 46 | } 47 | 48 | sub config_file { 49 | my ($self) = @_; 50 | return {}; 51 | } 52 | 53 | 1; 54 | 55 | package main; 56 | 57 | use FindBin qw($Bin); 58 | use lib "$Bin/../lib"; 59 | 60 | use Test::More; 61 | use Test::Trap; 62 | 63 | BEGIN { use_ok('App::ClusterSSH::Getopt') } 64 | 65 | my $getopts; 66 | 67 | my $mock_object = Test::ClusterSSH::Mock->new(); 68 | 69 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 70 | isa_ok( $getopts, 'App::ClusterSSH::Getopt' ); 71 | trap { 72 | $getopts->getopts; 73 | }; 74 | is( $trap->leaveby, 'return', 'getops on new object okay' ); 75 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 76 | is( $trap->stderr, '', 'Expecting no STDERR' ); 77 | is( $trap->die, undef, 'Expecting no die message' ); 78 | 79 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 80 | isa_ok( $getopts, 'App::ClusterSSH::Getopt' ); 81 | 82 | trap { 83 | $getopts->add_option(); 84 | }; 85 | is( $trap->leaveby, 'die', 'adding an empty option failed' ); 86 | is( $trap->die, 87 | q{No "spec" passed to add_option}, 88 | 'empty add_option message' 89 | ); 90 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 91 | is( $trap->stderr, '', 'Expecting no STDERR' ); 92 | 93 | trap { 94 | $getopts->add_option( spec => 'option' ); 95 | }; 96 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 97 | is( $trap->die, undef, 'no error when spec provided' ); 98 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 99 | is( $trap->stderr, '', 'Expecting no STDERR' ); 100 | trap { 101 | $getopts->getopts; 102 | }; 103 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 104 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 105 | is( $trap->stderr, '', 'Expecting no STDERR' ); 106 | is( $trap->die, undef, 'Expecting no die message' ); 107 | trap { 108 | $getopts->option; 109 | }; 110 | is( $trap->leaveby, 'return', 'calling option' ); 111 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 112 | is( $trap->stderr, '', 'Expecting no STDERR' ); 113 | is( $trap->die, undef, 'Expecting no die message' ); 114 | is( $getopts->option, undef, 'Expecting no die message' ); 115 | 116 | local @ARGV = '--option1'; 117 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 118 | trap { 119 | $getopts->add_option( spec => 'option1' ); 120 | }; 121 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 122 | is( $trap->die, undef, 'no error when spec provided' ); 123 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 124 | is( $trap->stderr, '', 'Expecting no STDERR' ); 125 | trap { 126 | $getopts->getopts; 127 | }; 128 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 129 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 130 | is( $trap->stderr, '', 'Expecting no STDERR' ); 131 | is( $trap->die, undef, 'Expecting no die message' ); 132 | trap { 133 | $getopts->option1; 134 | }; 135 | is( $trap->leaveby, 'return', 'calling option' ); 136 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 137 | is( $trap->stderr, '', 'Expecting no STDERR' ); 138 | is( $trap->die, undef, 'Expecting no die message' ); 139 | is( $getopts->option1, 1, 'Expecting no die message' ); 140 | 141 | local @ARGV = ''; # @ARGV is never undef, but an empty string 142 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 143 | trap { 144 | $getopts->add_option( spec => 'option1', default => 5 ); 145 | }; 146 | is( $trap->leaveby, 'return', 'adding an empty option with a default value' ); 147 | is( $trap->die, undef, 'no error when spec provided' ); 148 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 149 | is( $trap->stderr, '', 'Expecting no STDERR' ); 150 | trap { 151 | $getopts->getopts; 152 | }; 153 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 154 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 155 | is( $trap->stderr, '', 'Expecting no STDERR' ); 156 | is( $trap->die, undef, 'Expecting no die message' ); 157 | trap { 158 | $getopts->option1; 159 | }; 160 | is( $trap->leaveby, 'return', 'calling option' ); 161 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 162 | is( $trap->stderr, '', 'Expecting no STDERR' ); 163 | is( $trap->die, undef, 'Expecting no die message' ); 164 | is( $getopts->option1, 5, 'correct default value' ); 165 | 166 | local @ARGV = ( '--option1', '8' ); 167 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 168 | trap { 169 | $getopts->add_option( spec => 'option1=i', default => 5, ); 170 | }; 171 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 172 | is( $trap->die, undef, 'no error when spec provided' ); 173 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 174 | is( $trap->stderr, '', 'Expecting no STDERR' ); 175 | trap { 176 | $getopts->getopts; 177 | }; 178 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 179 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 180 | is( $trap->stderr, '', 'Expecting no STDERR' ); 181 | is( $trap->die, undef, 'Expecting no die message' ); 182 | trap { 183 | $getopts->option1; 184 | }; 185 | is( $trap->leaveby, 'return', 'calling option' ); 186 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 187 | is( $trap->stderr, '', 'Expecting no STDERR' ); 188 | is( $trap->die, undef, 'Expecting no die message' ); 189 | is( $getopts->option1, 8, 'default value overridden' ); 190 | 191 | @ARGV = ( '--option1', '--option2', 'string', '--option3', '10' ); 192 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 193 | trap { 194 | $getopts->add_option( spec => 'hidden', hidden => 1, no_acessor => 1, ); 195 | }; 196 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 197 | is( $trap->die, undef, 'no error when spec provided' ); 198 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 199 | is( $trap->stderr, '', 'Expecting no STDERR' ); 200 | trap { 201 | $getopts->add_option( spec => 'option1', help => 'help for 1' ); 202 | }; 203 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 204 | is( $trap->die, undef, 'no error when spec provided' ); 205 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 206 | is( $trap->stderr, '', 'Expecting no STDERR' ); 207 | trap { 208 | $getopts->add_option( spec => 'option2|o=s', help => 'help for 2' ); 209 | }; 210 | is( $trap->leaveby, 'return', 'adding option2 failed' ); 211 | is( $trap->die, undef, 'no error when spec provided' ); 212 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 213 | is( $trap->stderr, '', 'Expecting no STDERR' ); 214 | trap { 215 | $getopts->add_option( 216 | spec => 'option3|alt_opt|O=i', 217 | help => 'help for 3', 218 | default => 5 219 | ); 220 | }; 221 | is( $trap->leaveby, 'return', 'adding option3 failed' ); 222 | is( $trap->die, undef, 'no error when spec provided' ); 223 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 224 | is( $trap->stderr, '', 'Expecting no STDERR' ); 225 | trap { 226 | $getopts->getopts; 227 | }; 228 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 229 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 230 | is( $trap->stderr, '', 'Expecting no STDERR' ); 231 | is( $trap->die, undef, 'Expecting no die message' ); 232 | trap { 233 | $getopts->option1; 234 | }; 235 | is( $trap->leaveby, 'return', 'calling option1' ); 236 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 237 | is( $trap->stderr, '', 'Expecting no STDERR' ); 238 | is( $trap->die, undef, 'Expecting no die message' ); 239 | is( $getopts->option1, 1, 'option1 is as expected' ); 240 | trap { 241 | $getopts->option1; 242 | }; 243 | is( $trap->leaveby, 'return', 'calling option2' ); 244 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 245 | is( $trap->stderr, '', 'Expecting no STDERR' ); 246 | is( $trap->die, undef, 'Expecting no die message' ); 247 | is( $getopts->option2, 'string', 'option2 is as expected' ); 248 | trap { 249 | $getopts->option3; 250 | }; 251 | is( $trap->leaveby, 'return', 'calling option3' ); 252 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 253 | is( $trap->stderr, '', 'Expecting no STDERR' ); 254 | is( $trap->die, undef, 'Expecting no die message' ); 255 | is( $getopts->option3, 10, 'option3 is as expected' ); 256 | 257 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 258 | trap { 259 | $getopts->add_common_ssh_options; 260 | }; 261 | is( $trap->leaveby, 'return', 'calling option2' ); 262 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 263 | is( $trap->stderr, '', 'Expecting no STDERR' ); 264 | is( $trap->die, undef, 'Expecting no die message' ); 265 | trap { 266 | $getopts->getopts; 267 | }; 268 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 269 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 270 | is( $trap->stderr, '', 'Expecting no STDERR' ); 271 | is( $trap->die, undef, 'Expecting no die message' ); 272 | 273 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 274 | trap { 275 | $getopts->add_common_session_options; 276 | }; 277 | is( $trap->leaveby, 'return', 'calling option2' ); 278 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 279 | is( $trap->stderr, '', 'Expecting no STDERR' ); 280 | is( $trap->die, undef, 'Expecting no die message' ); 281 | trap { 282 | $getopts->getopts; 283 | }; 284 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 285 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 286 | is( $trap->stderr, '', 'Expecting no STDERR' ); 287 | is( $trap->die, undef, 'Expecting no die message' ); 288 | 289 | my $pod; 290 | @ARGV = ('--generate-pod'); 291 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 292 | $getopts->add_option( 293 | spec => 'long_opt|l=s', 294 | help => 'long opt help', 295 | default => 'default string' 296 | ); 297 | $getopts->add_option( spec => 'another_long_opt|n=i', ); 298 | $getopts->add_option( spec => 'a=s', help => 'short option only', ); 299 | $getopts->add_option( spec => 'long', help => 'long option only', ); 300 | trap { 301 | $getopts->getopts; 302 | }; 303 | is( $trap->leaveby, 'exit', 'adding an empty option failed' ); 304 | is( $trap->die, undef, 'no error when spec provided' ); 305 | ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); 306 | $pod = $trap->stdout; 307 | 308 | # run pod through a checker at some point as it should be 'clean' 309 | is( $trap->stderr, '', 'Expecting no STDERR' ); 310 | is( $trap->die, undef, 'Expecting no die message' ); 311 | 312 | @ARGV = ('--help'); 313 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 314 | trap { 315 | $getopts->getopts; 316 | }; 317 | is( $trap->leaveby, 'exit', 'adding an empty option failed' ); 318 | is( $trap->die, undef, 'no error when spec provided' ); 319 | ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); 320 | is( $trap->stderr, '', 'Expecting no STDERR' ); 321 | is( $trap->die, undef, 'Expecting no die message' ); 322 | 323 | @ARGV = ('-?'); 324 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 325 | trap { 326 | $getopts->getopts; 327 | }; 328 | is( $trap->leaveby, 'exit', 'adding an empty option failed' ); 329 | is( $trap->die, undef, 'no error when spec provided' ); 330 | ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); 331 | is( $trap->stderr, '', 'Expecting no STDERR' ); 332 | is( $trap->die, undef, 'Expecting no die message' ); 333 | 334 | @ARGV = ('-v'); 335 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 336 | trap { 337 | $getopts->getopts; 338 | }; 339 | is( $trap->leaveby, 'exit', 'version option exist okay' ); 340 | is( $trap->die, undef, 'no error when spec provided' ); 341 | like( $trap->stdout, qr/^Version: /, 'Version string correct' ); 342 | is( $trap->stderr, '', 'Expecting no STDERR' ); 343 | is( $trap->die, undef, 'Expecting no die message' ); 344 | 345 | @ARGV = ('-@'); 346 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); 347 | trap { 348 | $getopts->getopts; 349 | }; 350 | is( $trap->leaveby, 'exit', 'adding an empty option failed' ); 351 | is( $trap->die, undef, 'no error when spec provided' ); 352 | ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); 353 | like( $trap->stderr, qr{Unknown option: @}, 'Expecting no STDERR' ); 354 | is( $trap->die, undef, 'Expecting no die message' ); 355 | 356 | # test some common options 357 | @ARGV = ( 358 | '--unique-servers', '--title', 'title', '-p', 359 | '22', '--autoquit', '--tile', '--autoclose', 360 | '10', 361 | ); 362 | $mock_object->{auto_close} = 0; 363 | $mock_object->{auto_quit} = 0; 364 | $mock_object->{window_tiling} = 0; 365 | $mock_object->{show_history} = 0; 366 | $mock_object->{use_all_a_records} = 1; 367 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, ); 368 | trap { 369 | $getopts->getopts; 370 | }; 371 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 372 | is( $trap->die, undef, 'no error when spec provided' ); 373 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 374 | is( $trap->stderr, '', 'Expecting no STDERR' ); 375 | is( $trap->die, undef, 'Expecting no die message' ); 376 | is( $mock_object->{auto_close}, 10, 'auto_close set right' ); 377 | is( $mock_object->{auto_quit}, 1, 'auto_quit set right' ); 378 | is( $mock_object->{window_tiling}, 1, 'window_tiling set right' ); 379 | is( $mock_object->{show_history}, 0, 'show_history set right' ); 380 | is( $mock_object->{use_all_a_records}, 1, 'use_all_a_records set right' ); 381 | 382 | @ARGV = ( 383 | '--unique-servers', '--title', 'title', '-p', '22', '--autoquit', 384 | '--tile', '--show-history', '-A', 385 | ); 386 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, ); 387 | trap { 388 | $getopts->getopts; 389 | }; 390 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 391 | is( $trap->die, undef, 'no error when spec provided' ); 392 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 393 | is( $trap->stderr, '', 'Expecting no STDERR' ); 394 | is( $trap->die, undef, 'Expecting no die message' ); 395 | is( $mock_object->{auto_close}, 10, 'auto_close set right' ); 396 | is( $mock_object->{auto_quit}, 0, 'auto_quit set right' ); 397 | is( $mock_object->{window_tiling}, 0, 'window_tiling set right' ); 398 | is( $mock_object->{show_history}, 1, 'show_history set right' ); 399 | is( $mock_object->{use_all_a_records}, 0, 'use_all_a_records set right' ); 400 | 401 | TODO: { 402 | local $TODO = "explitely test for duplicate options"; 403 | $getopts = App::ClusterSSH::Getopt->new( 404 | parent => Test::ClusterSSH::Mock->new() ); 405 | trap { 406 | $getopts->add_option( spec => 'option1' ); 407 | }; 408 | is( $trap->leaveby, 'return', 'adding an empty option failed' ); 409 | is( $trap->die, undef, 'no error when spec provided' ); 410 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 411 | is( $trap->stderr, '', 'Expecting no STDERR' ); 412 | trap { 413 | $getopts->add_option( spec => 'option1' ); 414 | }; 415 | is( $trap->leaveby, 'die', 'adding an empty option failed' ); 416 | is( $trap->die, "bling bling", 'no error when spec provided' ); 417 | is( $trap->stdout, 'bling bling', 'Expecting no STDOUT' ); 418 | is( $trap->stderr, 'bling bling', 'Expecting no STDERR' ); 419 | trap { 420 | $getopts->getopts; 421 | }; 422 | is( $trap->leaveby, 'return', 'getops on object with spec okay' ); 423 | is( $trap->stdout, '', 'Expecting no STDOUT' ); 424 | is( $trap->stderr, '', 'Expecting no STDERR' ); 425 | is( $trap->die, undef, 'Expecting no die message' ); 426 | } 427 | 428 | @ARGV = ( '--rows', 5, '--cols', 10 ); 429 | $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, ); 430 | trap { 431 | $getopts->getopts; 432 | }; 433 | 434 | $trap->did_return(" ... returned"); 435 | $trap->quiet(" ... quietly"); 436 | is( $mock_object->{cols}, 10, 'cols set correctly' ); 437 | is( $mock_object->{rows}, 5, 'rows set correctly' ); 438 | 439 | done_testing; 440 | -------------------------------------------------------------------------------- /t/10host_ssh_config: -------------------------------------------------------------------------------- 1 | host server1 2 | host server2 server3 server4 3 | host server-5 4 | host server5.domain.name 5 | host server-6.domain.name 6 | #host server7 7 | -------------------------------------------------------------------------------- /t/10host_ssh_include: -------------------------------------------------------------------------------- 1 | include 10host_ssh_config 2 | host server_ssh_included 3 | -------------------------------------------------------------------------------- /t/15config.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # Force use of English in tests for the moment, for those users that 5 | # have a different locale set, since errors are hardcoded below 6 | use POSIX qw(setlocale locale_h); 7 | setlocale( LC_ALL, "C" ); 8 | 9 | use FindBin qw($Bin $Script); 10 | use lib "$Bin/../lib"; 11 | 12 | # fix path for finding our fake xterm on headless systems that do 13 | # not have it installed, such as TravisCI via github 14 | BEGIN { 15 | $ENV{PATH} = $ENV{PATH} . ':' . $Bin . '/bin'; 16 | } 17 | 18 | use Test::More; 19 | use Test::Trap; 20 | use File::Which qw(which); 21 | use File::Temp qw(tempdir); 22 | use Test::Differences; 23 | 24 | use Readonly; 25 | 26 | BEGIN { 27 | use_ok("App::ClusterSSH::Config") || BAIL_OUT('failed to use module'); 28 | } 29 | 30 | my $config; 31 | 32 | $config = App::ClusterSSH::Config->new(); 33 | isa_ok( $config, 'App::ClusterSSH::Config' ); 34 | 35 | Readonly::Hash my %default_config => { 36 | terminal => "xterm", 37 | terminal_args => "", 38 | terminal_title_opt => "-T", 39 | terminal_colorize => 1, 40 | terminal_bg_style => 'dark', 41 | terminal_allow_send_events => "-xrm '*.VT100.allowSendEvents:true'", 42 | terminal_font => "6x13", 43 | terminal_size => "80x24", 44 | 45 | use_hotkeys => "yes", 46 | key_quit => "Alt-q", 47 | key_addhost => "Control-Shift-plus", 48 | key_clientname => "Alt-n", 49 | key_history => "Alt-h", 50 | key_localname => "Alt-l", 51 | key_retilehosts => "Alt-r", 52 | key_macros_enable => "Alt-p", 53 | key_paste => "Control-v", 54 | key_username => "Alt-u", 55 | key_user_1 => "Alt-1", 56 | key_user_2 => "Alt-2", 57 | key_user_3 => "Alt-3", 58 | key_user_4 => "Alt-4", 59 | mouse_paste => "Button-2", 60 | auto_quit => "yes", 61 | auto_close => 5, 62 | window_tiling => "yes", 63 | window_tiling_direction => "right", 64 | console_position => "", 65 | 66 | screen_reserve_top => 0, 67 | screen_reserve_bottom => 60, 68 | screen_reserve_left => 0, 69 | screen_reserve_right => 0, 70 | 71 | terminal_reserve_top => 5, 72 | terminal_reserve_bottom => 0, 73 | terminal_reserve_left => 5, 74 | terminal_reserve_right => 0, 75 | 76 | terminal_decoration_height => 10, 77 | terminal_decoration_width => 8, 78 | 79 | ssh => '/usr/bin/ssh', 80 | 81 | console => 'console', 82 | console_args => '', 83 | rsh => 'rsh', 84 | rsh_args => "", 85 | telnet => 'telnet', 86 | telnet_args => "", 87 | ssh => 'ssh', 88 | ssh_args => "", 89 | sftp => 'sftp', 90 | sftp_args => "", 91 | 92 | extra_tag_file => "", 93 | extra_cluster_file => "", 94 | external_cluster_command => '', 95 | external_command_mode => '0600', 96 | external_command_pipe => '', 97 | 98 | unmap_on_redraw => "no", 99 | 100 | show_history => 0, 101 | history_width => 40, 102 | history_height => 10, 103 | 104 | hostname_override => '', 105 | 106 | command => q{}, 107 | command_pre => q{}, 108 | command_post => q{}, 109 | title => q{15CONFIG.T}, 110 | comms => q{ssh}, 111 | hide_menu => 0, 112 | max_host_menu_items => 30, 113 | 114 | macros_enabled => 'yes', 115 | macro_servername => '%s', 116 | macro_hostname => '%h', 117 | macro_username => '%u', 118 | macro_newline => '%n', 119 | macro_version => '%v', 120 | macro_user_1 => '%1', 121 | macro_user_2 => '%2', 122 | macro_user_3 => '%3', 123 | macro_user_4 => '%4', 124 | 125 | macro_user_1_command => '', 126 | macro_user_2_command => '', 127 | macro_user_3_command => '', 128 | macro_user_4_command => '', 129 | 130 | max_addhost_menu_cluster_items => 6, 131 | menu_send_autotearoff => 0, 132 | menu_host_autotearoff => 0, 133 | 134 | unique_servers => 0, 135 | use_all_a_records => 0, 136 | use_natural_sort => 0, 137 | 138 | send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu', 139 | 140 | # Debian #842965 141 | auto_wm_decoration_offsets => "no", 142 | 143 | # other bits inheritted from App::ClusterSSH::Base 144 | lang => 'en', 145 | user => '', 146 | rows => -1, 147 | cols => -1, 148 | 149 | fillscreen => 'no', 150 | }; 151 | my %expected = %default_config; 152 | is_deeply( $config, \%expected, 'default config is correct' ); 153 | 154 | $config = App::ClusterSSH::Config->new(); 155 | trap { 156 | $config = $config->validate_args( 157 | whoops => 'not there', 158 | doesnt_exist => 'whoops', 159 | ); 160 | }; 161 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); 162 | is( $trap->die, 163 | 'Unknown configuration parameters: doesnt_exist,whoops' . $/, 164 | 'got correct error message' 165 | ); 166 | is_deeply( 167 | $trap->die->unknown_config, 168 | [ 'doesnt_exist', 'whoops' ], 169 | 'Picked up unknown config array' 170 | ); 171 | isa_ok( $config, "App::ClusterSSH::Config" ); 172 | 173 | $expected{extra_cluster_file} = '/etc/filename'; 174 | $expected{rsh_args} = 'some args'; 175 | $expected{max_addhost_menu_cluster_items} = 120; 176 | trap { 177 | $config = $config->validate_args( 178 | extra_cluster_file => '/etc/filename', 179 | rsh_args => 'some args', 180 | max_addhost_menu_cluster_items => 120, 181 | ); 182 | }; 183 | is( $trap->die, undef, 'validated ok' ); 184 | isa_ok( $config, "App::ClusterSSH::Config" ); 185 | is_deeply( $config, \%expected, 'default config is correct' ); 186 | 187 | $config = App::ClusterSSH::Config->new(); 188 | %expected = %default_config; 189 | 190 | my $file = "$Bin/$Script.doesntexist"; 191 | trap { 192 | $config = $config->parse_config_file( $file, ); 193 | }; 194 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::LoadFile' ); 195 | is( $trap->die, 196 | "Unable to read file $file: No such file or directory" . $/, 197 | 'got correct error message' 198 | ); 199 | 200 | $file = "$Bin/$Script.file1"; 201 | note("using $file"); 202 | $config = App::ClusterSSH::Config->new(); 203 | %expected = %default_config; 204 | $expected{screen_reserve_left} = 100; 205 | $expected{screen_reserve_right} = 100; 206 | $expected{screen_reserve_top} = 100; 207 | $expected{screen_reserve_bottom} = 160; 208 | 209 | # Note: the parse_config here removes the key_user_x entries 210 | delete( $expected{"key_user_$_"} ) for (qw/ 1 2 3 4 /); 211 | trap { 212 | $config = $config->parse_config_file( $file, ); 213 | }; 214 | is( $trap->leaveby, 'return', 'returned ok' ); 215 | is( $trap->die, undef, 'returned ok' ); 216 | isa_ok( $config, "App::ClusterSSH::Config" ); 217 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 218 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 219 | is_deeply( $config, \%expected, 'amended config is correct' ); 220 | 221 | $file = "$Bin/$Script.file2"; 222 | note("using $file"); 223 | $config = App::ClusterSSH::Config->new(); 224 | %expected = %default_config; 225 | trap { 226 | $config = $config->parse_config_file( $file, ); 227 | }; 228 | is( $trap->leaveby, 'die', 'died ok' ); 229 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); 230 | is( $trap->die, 231 | 'Unknown configuration parameters: missing,rubbish' . $/, 232 | 'die message correct' 233 | ); 234 | isa_ok( $config, "App::ClusterSSH::Config" ); 235 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 236 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 237 | is_deeply( $config, \%expected, 'amended config is correct' ); 238 | 239 | $file = "$Bin/$Script.file3"; 240 | note("using $file"); 241 | $config = App::ClusterSSH::Config->new(); 242 | %expected = %default_config; 243 | trap { 244 | $config = $config->parse_config_file( $file, ); 245 | }; 246 | 247 | is( $trap->leaveby, 'return', 'returned ok' ); 248 | is( $trap->die, undef, 'returned ok' ); 249 | isa_ok( $config, "App::ClusterSSH::Config" ); 250 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 251 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 252 | 253 | note('find_binary tests'); 254 | my $path; 255 | $config = App::ClusterSSH::Config->new(); 256 | trap { 257 | $path = $config->find_binary(); 258 | }; 259 | is( $trap->leaveby, 'die', 'died ok' ); 260 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); 261 | isa_ok( $config, "App::ClusterSSH::Config" ); 262 | is( $trap->die, 'argument not provided' . $/, 'die message correct' ); 263 | isa_ok( $config, "App::ClusterSSH::Config" ); 264 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 265 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 266 | is_deeply( $config, \%expected, 'amended config is correct' ); 267 | 268 | trap { 269 | $path = $config->find_binary('missing'); 270 | }; 271 | is( $trap->leaveby, 'die', 'died ok' ); 272 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); 273 | isa_ok( $config, "App::ClusterSSH::Config" ); 274 | is( $trap->die, 275 | '"missing" binary not found - please amend $PATH or the cssh config file' 276 | . $/, 277 | 'die message correct' 278 | ); 279 | isa_ok( $config, "App::ClusterSSH::Config" ); 280 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 281 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 282 | is_deeply( $config, \%expected, 'amended config is correct' ); 283 | 284 | trap { 285 | $path = $config->find_binary('ls'); 286 | }; 287 | is( $trap->leaveby, 'return', 'returned ok' ); 288 | isa_ok( $config, "App::ClusterSSH::Config" ); 289 | isa_ok( $config, "App::ClusterSSH::Config" ); 290 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 291 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 292 | is_deeply( $config, \%expected, 'amended config is correct' ); 293 | is( $path, 'ls', 'Found correct path to "ls"' ); 294 | 295 | # check for a binary already found 296 | my $newpath; 297 | trap { 298 | $newpath = $config->find_binary($path); 299 | }; 300 | is( $trap->leaveby, 'return', 'returned ok' ); 301 | isa_ok( $config, "App::ClusterSSH::Config" ); 302 | isa_ok( $config, "App::ClusterSSH::Config" ); 303 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 304 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 305 | is_deeply( $config, \%expected, 'amended config is correct' ); 306 | is( $path, 'ls', 'Found correct path to "ls"' ); 307 | is( $path, $newpath, 'No change made from find_binary' ); 308 | 309 | # give false path to force another search 310 | trap { 311 | $newpath = $config->find_binary( '/does/not/exist/' . $path ); 312 | }; 313 | is( $trap->leaveby, 'return', 'returned ok' ); 314 | isa_ok( $config, "App::ClusterSSH::Config" ); 315 | isa_ok( $config, "App::ClusterSSH::Config" ); 316 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 317 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 318 | is_deeply( $config, \%expected, 'amended config is correct' ); 319 | is( $path, 'ls', 'Found correct path to "ls"' ); 320 | is( $path, $newpath, 'No change made from find_binary' ); 321 | 322 | note('Checks on loading configs'); 323 | note('empty dir'); 324 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 325 | $config = App::ClusterSSH::Config->new(); 326 | trap { 327 | $config->load_configs(); 328 | }; 329 | is( $trap->leaveby, 'return', 'returned ok' ); 330 | isa_ok( $config, "App::ClusterSSH::Config" ); 331 | isa_ok( $config, "App::ClusterSSH::Config" ); 332 | is( $trap->die, undef, 'die message correct' ); 333 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 334 | is( $trap->stderr, 335 | 'Created new configuration file within $HOME/.clusterssh/' . $/, 336 | 'Got correct STDERR output for .csshrc' 337 | ); 338 | 339 | #note(qx/ls -laR $ENV{HOME}/); 340 | ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); 341 | ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); 342 | is_deeply( $config, \%expected, 'amended config is correct' ); 343 | $ENV{HOME} = undef; 344 | 345 | note('.csshrc warning'); 346 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 347 | open( my $csshrc, '>', $ENV{HOME} . '/.csshrc' ); 348 | print $csshrc 'auto_quit = no', $/; 349 | close($csshrc); 350 | $expected{auto_quit} = 'no'; 351 | 352 | # Note: the load_configs here removes the key_user_x entries 353 | delete( $expected{"key_user_$_"} ) for (qw/ 1 2 3 4 /); 354 | $config = App::ClusterSSH::Config->new(); 355 | trap { 356 | $config->load_configs(); 357 | }; 358 | is( $trap->leaveby, 'return', 'returned ok' ); 359 | isa_ok( $config, "App::ClusterSSH::Config" ); 360 | isa_ok( $config, "App::ClusterSSH::Config" ); 361 | is( $trap->die, undef, 'die message correct' ); 362 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 363 | is( $trap->stderr, 364 | 'Moved $HOME/.csshrc to $HOME/.csshrc.DISABLED' 365 | . $/ 366 | . 'Created new configuration file within $HOME/.clusterssh/' 367 | . $/, 368 | 'Got correct STDERR output for .csshrc' 369 | ); 370 | ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); 371 | ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); 372 | is_deeply( $config, \%expected, 'amended config is correct' ); 373 | 374 | note('.csshrc warning and .clusterssh dir plus config'); 375 | 376 | # need to recreate .csshrc as it was just moved 377 | open( $csshrc, '>', $ENV{HOME} . '/.csshrc' ); 378 | print $csshrc 'auto_quit = no', $/; 379 | close($csshrc); 380 | $expected{auto_quit} = 'no'; 381 | open( $csshrc, '>', $ENV{HOME} . '/.clusterssh/config' ); 382 | print $csshrc 'window_tiling = no', $/; 383 | close($csshrc); 384 | $expected{window_tiling} = 'no'; 385 | $config = App::ClusterSSH::Config->new(); 386 | trap { 387 | $config->load_configs(); 388 | }; 389 | is( $trap->leaveby, 'return', 'returned ok' ); 390 | isa_ok( $config, "App::ClusterSSH::Config" ); 391 | isa_ok( $config, "App::ClusterSSH::Config" ); 392 | is( $trap->die, undef, 'die message correct' ); 393 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 394 | is( $trap->stderr, 395 | 'Moved $HOME/.csshrc to $HOME/.csshrc.DISABLED' . $/, 396 | 'Got correct STDERR output for .csshrc' 397 | ); 398 | ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); 399 | ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); 400 | is_deeply( $config, \%expected, 'amended config is correct' ); 401 | 402 | note('no .csshrc warning and .clusterssh dir'); 403 | unlink( $ENV{HOME} . '/.csshrc' ); 404 | $expected{auto_quit} = 'yes'; 405 | $config = App::ClusterSSH::Config->new(); 406 | trap { 407 | $config->load_configs(); 408 | }; 409 | is( $trap->leaveby, 'return', 'returned ok' ); 410 | isa_ok( $config, "App::ClusterSSH::Config" ); 411 | isa_ok( $config, "App::ClusterSSH::Config" ); 412 | is( $trap->die, undef, 'die message correct' ); 413 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 414 | is( $trap->stderr, '', 'Expecting no STDERR' ); 415 | ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); 416 | ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); 417 | is_deeply( $config, \%expected, 'amended config is correct' ); 418 | 419 | note('no .csshrc warning, .clusterssh dir plus config + extra config'); 420 | open( $csshrc, '>', $ENV{HOME} . '/clusterssh.config' ); 421 | print $csshrc 'terminal_args = something', $/; 422 | close($csshrc); 423 | $expected{terminal_args} = 'something'; 424 | $config = App::ClusterSSH::Config->new(); 425 | trap { 426 | $config->load_configs( $ENV{HOME} . '/clusterssh.config' ); 427 | }; 428 | is( $trap->leaveby, 'return', 'returned ok' ); 429 | isa_ok( $config, "App::ClusterSSH::Config" ); 430 | isa_ok( $config, "App::ClusterSSH::Config" ); 431 | is( $trap->die, undef, 'die message correct' ); 432 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 433 | is( $trap->stderr, '', 'Expecting no STDERR' ); 434 | ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); 435 | ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); 436 | is_deeply( $config, \%expected, 'amended config is correct' ); 437 | 438 | note('no .csshrc warning, .clusterssh dir plus config + more extra configs'); 439 | open( $csshrc, '>', $ENV{HOME} . '/.clusterssh/config_ABC' ); 440 | print $csshrc 'ssh_args = something', $/; 441 | close($csshrc); 442 | $expected{ssh_args} = 'something'; 443 | $config = App::ClusterSSH::Config->new(); 444 | trap { 445 | $config->load_configs( $ENV{HOME} . '/clusterssh.config', 'ABC' ); 446 | }; 447 | is( $trap->leaveby, 'return', 'returned ok' ); 448 | isa_ok( $config, "App::ClusterSSH::Config" ); 449 | isa_ok( $config, "App::ClusterSSH::Config" ); 450 | is( $trap->die, undef, 'die message correct' ); 451 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 452 | is( $trap->stderr, '', 'Expecting no STDERR' ); 453 | ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); 454 | ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); 455 | is_deeply( $config, \%expected, 'amended config is correct' ); 456 | 457 | note('check .clusterssh file is an error'); 458 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 459 | open( $csshrc, '>', $ENV{HOME} . '/.clusterssh' ); 460 | print $csshrc 'should_be_dir_not_file = PROBLEM', $/; 461 | close($csshrc); 462 | $config = App::ClusterSSH::Config->new(); 463 | trap { 464 | $config->write_user_config_file(); 465 | }; 466 | is( $trap->leaveby, 'die', 'died ok' ); 467 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); 468 | isa_ok( $config, "App::ClusterSSH::Config" ); 469 | is( $trap->die, 470 | 'Unable to create directory $HOME/.clusterssh: File exists' . $/, 471 | 'die message correct' 472 | ); 473 | isa_ok( $config, "App::ClusterSSH::Config" ); 474 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 475 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 476 | 477 | note('check failure to write default config is caught'); 478 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 479 | mkdir( $ENV{HOME} . '/.clusterssh' ); 480 | mkdir( $ENV{HOME} . '/.clusterssh/config' ); 481 | $config = App::ClusterSSH::Config->new(); 482 | trap { 483 | $config->write_user_config_file(); 484 | }; 485 | is( $trap->leaveby, 'die', 'died ok' ); 486 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); 487 | isa_ok( $config, "App::ClusterSSH::Config" ); 488 | is( $trap->die, 489 | 'Unable to write default $HOME/.clusterssh/config: Is a directory' . $/, 490 | 'die message correct' 491 | ); 492 | isa_ok( $config, "App::ClusterSSH::Config" ); 493 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 494 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 495 | 496 | note('check .clusterssh errors via load_configs are not fatal'); 497 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 498 | open( $csshrc, '>', $ENV{HOME} . '/.clusterssh' ); 499 | print $csshrc 'should_be_dir_not_file = PROBLEM', $/; 500 | close($csshrc); 501 | $config = App::ClusterSSH::Config->new(); 502 | trap { 503 | $config->load_configs(); 504 | }; 505 | is( $trap->leaveby, 'return', 'died ok' ); 506 | isa_ok( $config, "App::ClusterSSH::Config" ); 507 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 508 | is( $trap->stderr, 509 | q{Unable to create directory $HOME/.clusterssh: File exists} . $/ . $/, 510 | 'Expecting no STDERR' 511 | ); 512 | 513 | SKIP: { 514 | skip "Test inappropriate when running as root", 5 if $< == 0; 515 | note('move of .csshrc failure'); 516 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 517 | open( $csshrc, '>', $ENV{HOME} . '/.csshrc' ); 518 | print $csshrc "Something", $/; 519 | close($csshrc); 520 | open( $csshrc, '>', $ENV{HOME} . '/.csshrc.DISABLED' ); 521 | print $csshrc "Something else", $/; 522 | close($csshrc); 523 | chmod( 0666, $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} ); 524 | $config = App::ClusterSSH::Config->new(); 525 | trap { 526 | $config->write_user_config_file(); 527 | }; 528 | is( $trap->leaveby, 'die', 'died ok' ); 529 | isa_ok( $config, "App::ClusterSSH::Config" ); 530 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 531 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 532 | is( $trap->die, 533 | q{Unable to create directory $HOME/.clusterssh: Permission denied} 534 | . $/, 535 | 'Expected die msg ' . $trap->stderr 536 | ); 537 | chmod( 0755, $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} ); 538 | } 539 | 540 | note('check failure to write default config is caught when loading config'); 541 | $ENV{HOME} = tempdir( CLEANUP => 1 ); 542 | mkdir( $ENV{HOME} . '/.clusterssh' ); 543 | mkdir( $ENV{HOME} . '/.clusterssh/config' ); 544 | $config = App::ClusterSSH::Config->new(); 545 | trap { 546 | $config->load_configs(); 547 | }; 548 | is( $trap->leaveby, 'return', 'returned ok' ); 549 | isa_ok( $config, "App::ClusterSSH::Config" ); 550 | isa_ok( $config, "App::ClusterSSH::Config" ); 551 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 552 | is( $trap->stderr, 553 | q{Unable to write default $HOME/.clusterssh/config: Is a directory} 554 | . $/ 555 | . $/, 556 | 'Expecting no STDERR' 557 | ); 558 | 559 | note('Checking dump'); 560 | $config = App::ClusterSSH::Config->new( 561 | send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu', ); 562 | 563 | trap { 564 | $config->dump(); 565 | }; 566 | my $expected = qq{# Configuration dump produced by "cssh -d" 567 | auto_close=5 568 | auto_quit=yes 569 | auto_wm_decoration_offsets=no 570 | cols=-1 571 | command_post= 572 | command_pre= 573 | console=console 574 | console_args= 575 | console_position= 576 | external_cluster_command= 577 | external_command_mode=0600 578 | external_command_pipe= 579 | extra_cluster_file= 580 | extra_tag_file= 581 | fillscreen=no 582 | hide_menu=0 583 | history_height=10 584 | history_width=40 585 | hostname_override= 586 | key_addhost=Control-Shift-plus 587 | key_clientname=Alt-n 588 | key_history=Alt-h 589 | key_localname=Alt-l 590 | key_macros_enable=Alt-p 591 | key_paste=Control-v 592 | key_quit=Alt-q 593 | key_retilehosts=Alt-r 594 | key_user_1=Alt-1 595 | key_user_2=Alt-2 596 | key_user_3=Alt-3 597 | key_user_4=Alt-4 598 | key_username=Alt-u 599 | lang=en 600 | macro_hostname=%h 601 | macro_newline=%n 602 | macro_servername=%s 603 | macro_user_1=%1 604 | macro_user_1_command= 605 | macro_user_2=%2 606 | macro_user_2_command= 607 | macro_user_3=%3 608 | macro_user_3_command= 609 | macro_user_4=%4 610 | macro_user_4_command= 611 | macro_username=%u 612 | macro_version=%v 613 | macros_enabled=yes 614 | max_addhost_menu_cluster_items=6 615 | max_host_menu_items=30 616 | menu_host_autotearoff=0 617 | menu_send_autotearoff=0 618 | mouse_paste=Button-2 619 | rows=-1 620 | rsh=rsh 621 | rsh_args= 622 | screen_reserve_bottom=60 623 | screen_reserve_left=0 624 | screen_reserve_right=0 625 | screen_reserve_top=0 626 | send_menu_xml_file=} . $ENV{HOME} . qq{/.clusterssh/send_menu 627 | sftp=sftp 628 | sftp_args= 629 | show_history=0 630 | ssh=ssh 631 | ssh_args= 632 | telnet=telnet 633 | telnet_args= 634 | terminal=xterm 635 | terminal_allow_send_events=-xrm '*.VT100.allowSendEvents:true' 636 | terminal_args= 637 | terminal_bg_style=dark 638 | terminal_colorize=1 639 | terminal_decoration_height=10 640 | terminal_decoration_width=8 641 | terminal_font=6x13 642 | terminal_reserve_bottom=0 643 | terminal_reserve_left=5 644 | terminal_reserve_right=0 645 | terminal_reserve_top=5 646 | terminal_size=80x24 647 | terminal_title_opt=-T 648 | unique_servers=0 649 | unmap_on_redraw=no 650 | use_all_a_records=0 651 | use_hotkeys=yes 652 | use_natural_sort=0 653 | #user= 654 | window_tiling=yes 655 | window_tiling_direction=right 656 | }; 657 | 658 | isa_ok( $config, "App::ClusterSSH::Config" ); 659 | is( $trap->die, undef, 'die message correct' ); 660 | eq_or_diff( $trap->stdout, $expected, 'Expecting no STDOUT' ); 661 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 662 | 663 | done_testing(); 664 | -------------------------------------------------------------------------------- /t/15config.t.file1: -------------------------------------------------------------------------------- 1 | screen_reserve_top = 100 2 | screen_reserve_bottom = 160 3 | 4 | screen_reserve_left = 100 5 | 6 | screen_reserve_right = 100 7 | 8 | -------------------------------------------------------------------------------- /t/15config.t.file2: -------------------------------------------------------------------------------- 1 | missing=what 2 | rubbish=here 3 | -------------------------------------------------------------------------------- /t/15config.t.file3: -------------------------------------------------------------------------------- 1 | # Configuration dump produced by 'cssh -u' 2 | auto_quit=yes 3 | clusters=duncs test fred duncs1 fred1 test1 test2 test3 test4 test5 live test dev kvm 4 | command= 5 | comms=ssh 6 | console_position= 7 | extra_cluster_file= 8 | extra_tag_file= 9 | history_height=10 10 | history_width=40 11 | key_addhost=Control-Shift-plus 12 | key_clientname=Alt-n 13 | key_history=Alt-h 14 | key_localname=Alt-l 15 | key_paste=Control-v 16 | key_quit=Control-q 17 | key_retilehosts=Alt-r 18 | key_username=Alt-n 19 | key_user_1=Alt-1 20 | key_user_2=Alt-2 21 | key_user_3=Alt-3 22 | key_user_4=Alt-4 23 | max_host_menu_items=30 24 | method=ssh 25 | mouse_paste=Button-2 26 | rsh_args= 27 | screen_reserve_bottom=60 28 | screen_reserve_left=0 29 | screen_reserve_right=0 30 | screen_reserve_top=0 31 | show_history=0 32 | ssh=/usr/bin/ssh 33 | ssh_args= -x -o ConnectTimeout=10 34 | telnet_args= 35 | terminal=/usr/bin/xterm 36 | terminal_allow_send_events=-xrm '*.VT100.allowSendEvents:true' 37 | terminal_args= 38 | terminal_bg_style=dark 39 | terminal_colorize=1 40 | terminal_decoration_height=10 41 | terminal_decoration_width=8 42 | terminal_font=6x13 43 | terminal_reserve_bottom=0 44 | terminal_reserve_left=5 45 | terminal_reserve_right=0 46 | terminal_reserve_top=5 47 | terminal_size=80x24 48 | terminal_title_opt=-T 49 | title=CSSH 50 | unmap_on_redraw=no 51 | use_hotkeys=yes 52 | window_tiling=yes 53 | window_tiling_direction=right 54 | duncs=orion 55 | test=macbook 56 | fred=duncs test 57 | duncs1=orion 58 | test1=macbook 59 | fred1=duncs test 60 | test2=macbook 61 | test3=macbook 62 | test4=macbook 63 | test5=macbook 64 | live = live1 live2 live3 \ 65 | live4 live 5 live 6 66 | test=test1 test2 test3 test4 67 | dev=dev1 dev2 dev3 dev4 68 | -------------------------------------------------------------------------------- /t/20helper.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # Force use of English in tests for the moment, for those users that 5 | # have a different locale set, since errors are hardcoded below 6 | use POSIX qw(setlocale locale_h); 7 | setlocale( LC_ALL, "C" ); 8 | 9 | use FindBin qw($Bin $Script); 10 | use lib "$Bin/../lib"; 11 | 12 | use Test::More; 13 | use Test::Trap; 14 | use File::Which qw(which); 15 | use File::Temp qw(tempdir); 16 | 17 | use Readonly; 18 | 19 | package App::ClusterSSH::Config; 20 | 21 | sub new { 22 | my ( $class, %args ) = @_; 23 | my $self = {%args}; 24 | return bless $self, $class; 25 | } 26 | 27 | package main; 28 | 29 | BEGIN { 30 | use_ok("App::ClusterSSH::Helper") || BAIL_OUT('failed to use module'); 31 | } 32 | 33 | my $helper; 34 | 35 | $helper = App::ClusterSSH::Helper->new(); 36 | isa_ok( $helper, 'App::ClusterSSH::Helper' ); 37 | 38 | my $script; 39 | 40 | trap { 41 | $script = $helper->script; 42 | }; 43 | is( $trap->leaveby, 'die', 'returned ok' ); 44 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 45 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 46 | is( $trap->die, 'No configuration provided or in wrong format', 'no config' ); 47 | 48 | trap { 49 | $script = $helper->script( something => 'nothing' ); 50 | }; 51 | is( $trap->leaveby, 'die', 'returned ok' ); 52 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 53 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 54 | is( $trap->die, 'No configuration provided or in wrong format', 55 | 'bad format' ); 56 | 57 | my $mock_config = App::ClusterSSH::Config->new(); 58 | trap { 59 | $script = $helper->script($mock_config); 60 | }; 61 | is( $trap->leaveby, 'die', 'returned ok' ); 62 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 63 | 64 | # ignore stderr here as it will complain about missing xxx_arg var 65 | #is( $trap->stderr, q{}, 'Expecting no STDERR' ); 66 | is( $trap->die, q{Config 'comms' not provided}, 'missing arg' ); 67 | 68 | $mock_config->{comms} = 'method'; 69 | trap { 70 | $script = $helper->script($mock_config); 71 | }; 72 | is( $trap->leaveby, 'die', 'returned ok' ); 73 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 74 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 75 | is( $trap->die, q{Config 'method' not provided}, 'missing arg' ); 76 | 77 | $mock_config->{method} = 'binary'; 78 | trap { 79 | $script = $helper->script($mock_config); 80 | }; 81 | is( $trap->leaveby, 'die', 'returned ok' ); 82 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 83 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 84 | is( $trap->die, q{Config 'method_args' not provided}, 'missing arg' ); 85 | 86 | $mock_config->{method_args} = 'rubbish'; 87 | $mock_config->{command} = 'echo'; 88 | $mock_config->{auto_close} = 5; 89 | trap { 90 | $script = $helper->script($mock_config); 91 | }; 92 | is( $trap->leaveby, 'return', 'returned ok' ); 93 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 94 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 95 | is( $trap->die, undef, 'not died' ); 96 | 97 | trap { 98 | eval {$script}; 99 | }; 100 | is( $trap->leaveby, 'return', 'returned ok' ); 101 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 102 | is( $trap->stderr, q{}, 'Expecting no STDERR' ); 103 | is( $trap->die, undef, 'not died' ); 104 | 105 | done_testing(); 106 | -------------------------------------------------------------------------------- /t/30cluster.cannot_read: -------------------------------------------------------------------------------- 1 | #cannot read this file 2 | -------------------------------------------------------------------------------- /t/30cluster.file1: -------------------------------------------------------------------------------- 1 | tag1 host1 2 | -------------------------------------------------------------------------------- /t/30cluster.file2: -------------------------------------------------------------------------------- 1 | # a comment 2 | tag1 host1 3 | tag2 host2 4 | 5 | #line wrapped 6 | tag3 host3 \ 7 | host4 8 | 9 | -------------------------------------------------------------------------------- /t/30cluster.file3: -------------------------------------------------------------------------------- 1 | # a comment 2 | tag1 host1 3 | tag2 host2 4 | 5 | #line wrapped 6 | tag3 host3 \ 7 | host4 8 | 9 | 10 | default host7 host8 host9 11 | -------------------------------------------------------------------------------- /t/30cluster.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # Force use of English in tests for the moment, for those users that 5 | # have a different locale set, since errors are hardcoded below 6 | use POSIX qw(setlocale locale_h); 7 | setlocale( LC_ALL, "C" ); 8 | 9 | use FindBin qw($Bin $Script); 10 | use lib "$Bin/../lib"; 11 | 12 | use Test::More; 13 | use Test::Trap; 14 | use File::Which qw(which); 15 | use English '-no_match_vars'; 16 | 17 | use Readonly; 18 | 19 | package Test::ClusterSSH::Mock; 20 | 21 | # generate purpose object used to simplfy testing 22 | 23 | sub new { 24 | my ( $class, %args ) = @_; 25 | my $config = {%args}; 26 | return bless $config, $class; 27 | } 28 | 29 | sub parent { 30 | my ($self) = @_; 31 | return $self; 32 | } 33 | 34 | sub config { 35 | my ($self) = @_; 36 | return $self; 37 | } 38 | 39 | sub load_configs { 40 | my ($self) = @_; 41 | return $self; 42 | } 43 | 44 | sub config_file { 45 | my ($self) = @_; 46 | return {}; 47 | } 48 | 49 | 1; 50 | 51 | package main; 52 | 53 | BEGIN { 54 | $ENV{PATH} = $ENV{PATH} . ':' . $Bin . '/bin'; 55 | use_ok("App::ClusterSSH::Cluster") || BAIL_OUT('failed to use module'); 56 | use_ok("App::ClusterSSH::Config") || BAIL_OUT('failed to use module'); 57 | } 58 | 59 | my $mock_object = Test::ClusterSSH::Mock->new(); 60 | 61 | my $cluster1 = App::ClusterSSH::Cluster->new( parent => $mock_object ); 62 | isa_ok( $cluster1, 'App::ClusterSSH::Cluster' ); 63 | 64 | my $cluster2 = App::ClusterSSH::Cluster->new(); 65 | isa_ok( $cluster2, 'App::ClusterSSH::Cluster' ); 66 | 67 | my %expected = ( people => [ 'fred', 'jo', 'pete', ] ); 68 | 69 | $cluster1->register_tag( 'people', @{ $expected{people} } ); 70 | 71 | my @got = $cluster2->get_tag('people'); 72 | is_deeply( \@got, \@{ $expected{people} }, 'Shared cluster object' ) 73 | or diag explain @got; 74 | my %got = $cluster2->dump_tags; 75 | 76 | is_deeply( \%got, \%expected, 'Shared cluster object' ) or diag explain %got; 77 | 78 | # should pass without issue 79 | trap { 80 | $cluster1->read_cluster_file( $Bin . '/30cluster.doesnt exist' ); 81 | }; 82 | is( !$trap, '', 'coped with missing file ok' ); 83 | isa_ok( $cluster1, 'App::ClusterSSH::Cluster' ); 84 | 85 | # no point running this test as root since root cannot be blocked 86 | # from accessing the file 87 | TODO: { 88 | if ( $EUID != 0 ) { 89 | my $no_read = $Bin . '/30cluster.cannot_read'; 90 | chmod 0000, $no_read; 91 | trap { 92 | $cluster1->read_cluster_file($no_read); 93 | }; 94 | chmod 0644, $no_read; 95 | isa_ok( $trap->die, 'App::ClusterSSH::Exception::LoadFile' ); 96 | is( $trap->die, 97 | "Unable to read file $no_read: Permission denied", 98 | 'Error on reading an existing file ok' 99 | ); 100 | } 101 | else { 102 | pass('Cannot test for lack of read access when run as root'); 103 | } 104 | } 105 | 106 | $expected{tag1} = ['host1']; 107 | $cluster1->read_cluster_file( $Bin . '/30cluster.file1' ); 108 | test_expected( 'file 1', %expected ); 109 | 110 | $expected{tag2} = [ 'host2', ]; 111 | $expected{tag3} = [ 'host3', 'host4' ]; 112 | $cluster1->read_cluster_file( $Bin . '/30cluster.file2' ); 113 | test_expected( 'file 2', %expected ); 114 | 115 | $expected{tag10} = [ 'host10', 'host20', 'host30' ]; 116 | $expected{tag20} = [ 'host10', ]; 117 | $expected{tag30} = [ 'host10', ]; 118 | $expected{tag40} = [ 'host20', 'host30', ]; 119 | $expected{tag50} = [ 'host30', ]; 120 | $cluster1->read_tag_file( $Bin . '/30cluster.tag1' ); 121 | test_expected( 'tag 1', %expected ); 122 | 123 | $cluster1->read_cluster_file( $Bin . '/30cluster.file3' ); 124 | my @default_expected = (qw/ host7 host8 host9 /); 125 | $expected{default} = \@default_expected; 126 | test_expected( 'file 3', %expected ); 127 | my @default = $cluster1->get_tag('default'); 128 | is_deeply( \@default, \@default_expected, 'default cluster ok' ); 129 | 130 | is( scalar $cluster1->get_tag('default'), 131 | scalar @default_expected, 132 | 'Count correct' 133 | ); 134 | 135 | my $tags; 136 | trap { 137 | $tags = $cluster1->get_tag('does_not_exist'); 138 | }; 139 | is( $trap->leaveby, 'return', 'non-existant tag returns correctly' ); 140 | is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); 141 | is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); 142 | is( $tags, undef, 'non-existant tag returns undef' ); 143 | 144 | @default_expected 145 | = sort qw/ default people tag1 tag2 tag3 tag10 tag20 tag30 tag40 tag50 /; 146 | trap { 147 | @default = $cluster1->list_tags; 148 | }; 149 | is( $trap->leaveby, 'return', 'list_tags returned okay' ); 150 | is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); 151 | is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); 152 | is_deeply( \@default, \@default_expected, 'tag list correct' ); 153 | 154 | my $count; 155 | trap { 156 | $count = $cluster1->list_tags; 157 | }; 158 | is( $trap->leaveby, 'return', 'list_tags returned okay' ); 159 | is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); 160 | is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); 161 | is_deeply( $count, 10, 'tag list count correct' ); 162 | 163 | # now checks against running an external command 164 | 165 | my @external_expected; 166 | 167 | # text fetching external clusters when no command set or runnable 168 | #$mock_object->{external_cluster_command} = '/tmp/doesnt_exist'; 169 | trap { 170 | @external_expected = $cluster1->_run_external_clusters(); 171 | }; 172 | is( $trap->leaveby, 'return', 'non-existant tag returns correctly' ); 173 | is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); 174 | is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); 175 | is( $tags, undef, 'non-existant tag returns undef' ); 176 | @external_expected = $cluster1->list_external_clusters(); 177 | is_deeply( \@external_expected, [], 'External command doesnt exist' ); 178 | is( scalar $cluster1->list_external_clusters, 179 | 0, 'External command failed tag count' ); 180 | 181 | $mock_object->{external_cluster_command} = "$Bin/external_cluster_command"; 182 | 183 | @external_expected = $cluster1->list_external_clusters(); 184 | is_deeply( 185 | \@external_expected, 186 | [qw/ tag100 tag200 tag300 tag400 /], 187 | 'External command no args' 188 | ); 189 | is( scalar $cluster1->list_external_clusters, 190 | 4, 'External command tag count' ); 191 | 192 | @external_expected = $cluster1->get_external_clusters(); 193 | is_deeply( \@external_expected, [], 'External command no args' ); 194 | 195 | @external_expected = $cluster1->get_external_clusters("tag1 tag2"); 196 | is_deeply( \@external_expected, [qw/tag1 tag2 /], 197 | 'External command: 2 args passed through' ); 198 | 199 | @external_expected = $cluster1->get_external_clusters("tag100"); 200 | is_deeply( \@external_expected, [qw/host100 /], 201 | 'External command: 1 tag expanded to one host' ); 202 | 203 | @external_expected = $cluster1->get_external_clusters("tag200"); 204 | is_deeply( 205 | \@external_expected, 206 | [qw/host200 host205 host210 /], 207 | 'External command: 1 tag expanded to 3 hosts and sorted' 208 | ); 209 | 210 | @external_expected = $cluster1->get_external_clusters("tag400"); 211 | is_deeply( 212 | \@external_expected, 213 | [ qw/host100 host200 host205 host210 host300 host325 host350 host400 host401 / 214 | ], 215 | 'External command: 1 tag expanded with self referencing tags' 216 | ); 217 | 218 | # NOTE 219 | # Since this is calling a shell run command, the tests cannot capture 220 | # the shell STDOUT and STDERR. By default redirect STDOUT and STDERR into 221 | # /dev/null so it dones't make noise in normal test output 222 | # However, don't hide it if running with -v flag 223 | my $redirect = ' 1>/dev/null 2>&1'; 224 | if ( $ENV{TEST_VERBOSE} ) { 225 | $redirect = ''; 226 | } 227 | 228 | trap { 229 | @external_expected = $cluster1->get_external_clusters("-x $redirect"); 230 | }; 231 | like( 232 | $trap->die, 233 | qr/External command failure.*external_cluster_command.*Return Code: 5/ms, 234 | 'External command: caught exception message' 235 | ); 236 | is( $trap->stdout, '', 'External command: no stdout from perl code' ); 237 | is( $trap->stderr, '', 'External command: no stderr from perl code' ); 238 | 239 | trap { 240 | @external_expected = $cluster1->get_external_clusters("-q $redirect"); 241 | }; 242 | like( 243 | $trap->die, 244 | qr/External command failure.*external_cluster_command.*Return Code: 255/ms, 245 | 'External command: caught exception message' 246 | ); 247 | is( $trap->stdout, '', 'External command: no stdout from perl code' ); 248 | is( $trap->stderr, '', 'External command: no stderr from perl code' ); 249 | 250 | # check reading of cluster files 251 | trap { 252 | $cluster1->get_cluster_entries( $Bin . '/30cluster.file3' ); 253 | }; 254 | is( $trap->leaveby, 'return', 'exit okay on get_cluster_entries' ); 255 | is( $trap->stdout, '', 'no stdout for get_cluster_entries' ); 256 | is( $trap->stderr, '', 'no stderr for get_cluster_entries' ); 257 | 258 | # check reading of tag files 259 | trap { 260 | $cluster1->get_tag_entries( $Bin . '/30cluster.tag1' ); 261 | }; 262 | is( $trap->leaveby, 'return', 'exit okay on get_tag_entries' ); 263 | is( $trap->stdout, '', 'no stdout for get_tag_entries' ); 264 | is( $trap->stderr, '', 'no stderr for get_tag_entries' ); 265 | 266 | # This step is required for using find_binary within the underlying 267 | # code of the following methods 268 | $cluster1->set_config( App::ClusterSSH::Config->new() ); 269 | 270 | # test bash expansion 271 | my @expected = ( 'aa', 'ab', 'ac' ); 272 | $cluster1->register_tag( 'glob1', 'a{a,b,c}' ); 273 | @got = $cluster2->get_tag('glob1'); 274 | is_deeply( \@got, \@expected, 'glob1 expansion, words' ) 275 | or diag explain @got; 276 | 277 | @expected = ( 'ax', 'ay', 'az' ); 278 | $cluster1->register_tag( 'glob2', 'a{x..z}' ); 279 | @got = $cluster2->get_tag('glob2'); 280 | is_deeply( \@got, \@expected, 'glob2 expansion, words' ) 281 | or diag explain @got; 282 | 283 | @expected = ( 'b1', 'b2', 'b3' ); 284 | $cluster1->register_tag( 'glob3', 'b{1..3}' ); 285 | @got = $cluster2->get_tag('glob3'); 286 | is_deeply( \@got, \@expected, 'glob3 expansion, number range' ) 287 | or diag explain @got; 288 | 289 | @expected = ( 'ca', 'cb', 'cc', 'd7', 'd8', 'd9' ); 290 | $cluster1->register_tag( 'glob4', 'c{a..c}', 'd{7..9}' ); 291 | @got = $cluster2->get_tag('glob4'); 292 | is_deeply( \@got, \@expected, 'glob4 expansion, mixed' ) 293 | or diag explain @got; 294 | 295 | # make sure reasonable expansions get through with no nasty metachars 296 | # This one does not work due to the way File::Glob works 297 | #@expected = ( 'cd..f}', 'c{a..c' ); 298 | @expected = ( 'c', 'cd..f}' ); 299 | $cluster1->register_tag( 'glob5', 'c{a..c', 'cd..f}' ); 300 | @got = $cluster2->get_tag('glob5'); 301 | is_deeply( \@got, \@expected, 'glob5 expansion, mixed' ) 302 | or diag explain @got; 303 | 304 | @expected = (); 305 | trap { 306 | $cluster1->register_tag( 'glob6', 'c{a..c} ; echo NASTY' ); 307 | }; 308 | is( $trap->leaveby, 'return', 'didnt die on nasty chars' ); 309 | is( $trap->die, undef, 'didnt die on nasty chars' ); 310 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 311 | like( 312 | $trap->stderr, 313 | qr/Bad characters picked up in tag 'glob6':.*/, 314 | 'warned on nasty chars' 315 | ); 316 | @got = $cluster2->get_tag('glob6'); 317 | is_deeply( \@got, \@expected, 'glob6 expansion, nasty chars' ) 318 | or diag explain @got; 319 | 320 | @expected = (); 321 | trap { 322 | $cluster1->register_tag( 'glob7', 'c{a..b} `echo NASTY`' ); 323 | }; 324 | is( $trap->leaveby, 'return', 'didnt die on nasty chars' ); 325 | is( $trap->die, undef, 'didnt die on nasty chars' ); 326 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 327 | like( 328 | $trap->stderr, 329 | qr/Bad characters picked up in tag 'glob7':.*/, 330 | 'warned on nasty chars' 331 | ); 332 | @got = $cluster2->get_tag('glob7'); 333 | is_deeply( \@got, \@expected, 'glob7 expansion, nasty chars' ) 334 | or diag explain @got; 335 | 336 | @expected = (); 337 | trap { 338 | $cluster1->register_tag( 'glob8', 'c{a..b} $!', ); 339 | }; 340 | is( $trap->leaveby, 'return', 'didnt die on nasty chars' ); 341 | is( $trap->die, undef, 'didnt die on nasty chars' ); 342 | is( $trap->stdout, q{}, 'Expecting no STDOUT' ); 343 | like( 344 | $trap->stderr, 345 | qr/Bad characters picked up in tag 'glob8':.*/, 346 | 'warned on nasty chars' 347 | ); 348 | @got = $cluster2->get_tag('glob8'); 349 | is_deeply( \@got, \@expected, 'glob8 expansion, nasty chars' ) 350 | or diag explain @got; 351 | 352 | done_testing(); 353 | 354 | sub test_expected { 355 | my ( $test, %expected ) = @_; 356 | 357 | foreach my $key ( keys %expected ) { 358 | my @got = $cluster2->get_tag($key); 359 | is_deeply( 360 | \@got, 361 | \@{ $expected{$key} }, 362 | 'file ' . $test . ' get_tag on: ' . $key 363 | ) or diag explain @got; 364 | } 365 | 366 | my %got = $cluster1->dump_tags; 367 | is_deeply( \%got, \%expected, 'file ' . $test . ' dump_tags' ) 368 | or diag explain %got; 369 | } 370 | -------------------------------------------------------------------------------- /t/30cluster.tag1: -------------------------------------------------------------------------------- 1 | host10 tag10 tag20 tag30 2 | host20 tag10 # same host split over two lines 3 | host30 tag10 4 | host20 tag40 # part two of earlier host 5 | host30 tag40 \ # multi line second part tag 6 | tag50 7 | -------------------------------------------------------------------------------- /t/80clusterssh.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # Force use of English in tests for the moment, for those users that 5 | # have a different locale set, since errors are hardcoded below 6 | use POSIX qw(setlocale locale_h); 7 | setlocale( LC_ALL, "C" ); 8 | 9 | use FindBin qw($Bin $Script); 10 | use lib "$Bin/../lib"; 11 | 12 | # fix path for finding our fake xterm on headless systems that do 13 | # not have it installed, such as TravisCI via github 14 | BEGIN { 15 | $ENV{PATH} = $ENV{PATH} . ':' . $Bin . '/bin'; 16 | } 17 | 18 | use Test::More; 19 | use Test::Trap; 20 | use File::Which qw(which); 21 | 22 | use Readonly; 23 | 24 | BEGIN { use_ok("App::ClusterSSH") } 25 | 26 | my $app; 27 | 28 | $app = App::ClusterSSH->new(); 29 | isa_ok( $app, 'App::ClusterSSH' ); 30 | isa_ok( $app->config, 'App::ClusterSSH::Config' ); 31 | 32 | for my $submod (qw/ cluster helper options window /) { 33 | trap { 34 | $app->$submod; 35 | }; 36 | $trap->quiet("$submod loaded okay"); 37 | } 38 | 39 | trap { 40 | $app->exit_prog; 41 | }; 42 | $trap->quiet("No errors from exit_prog call"); 43 | 44 | my @provided = (qw/ one one one two two three four four four /); 45 | my @expected = sort (qw/ one two three four /); 46 | my @got; 47 | trap { 48 | @got = sort $app->remove_repeated_servers(@provided); 49 | }; 50 | is_deeply( \@got, \@expected, "Repeated servers removed okay" ); 51 | 52 | done_testing(); 53 | -------------------------------------------------------------------------------- /t/bin/xterm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # small 'fake' script to allow xterm to be found when performing tests 4 | # on systems that do not have it 5 | 6 | warn "$_=$ENV{$_}", $/ for ( sort keys %ENV ) if ( $ENV{TEST_VERBOSE} ); 7 | 8 | exit 0 9 | -------------------------------------------------------------------------------- /t/boilerplate.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | sub not_in_file_ok { 8 | my ( $filename, %regex ) = @_; 9 | open( my $fh, '<', $filename ) 10 | or die "couldn't open $filename for reading: $!"; 11 | 12 | my %violated; 13 | 14 | while ( my $line = <$fh> ) { 15 | while ( my ( $desc, $regex ) = each %regex ) { 16 | if ( $line =~ $regex ) { 17 | push @{ $violated{$desc} ||= [] }, $.; 18 | } 19 | } 20 | } 21 | 22 | if (%violated) { 23 | fail("$filename contains boilerplate text"); 24 | diag "$_ appears on lines @{$violated{$_}}" for keys %violated; 25 | } 26 | else { 27 | pass("$filename contains no boilerplate text"); 28 | } 29 | } 30 | 31 | sub module_boilerplate_ok { 32 | my ($module) = @_; 33 | not_in_file_ok( 34 | $module => 'the great new $MODULENAME' => qr/ - The great new /, 35 | 'boilerplate description' => qr/Quick summary of what the module/, 36 | 'stub function definition' => qr/function[12]/, 37 | ); 38 | } 39 | 40 | TODO: { 41 | not_in_file_ok( 42 | README => "The README is used..." => qr/The README is used/, 43 | "'version information here'" => qr/to provide version information/, 44 | ); 45 | 46 | not_in_file_ok( Changes => "placeholder date/time" => qr(Date/time) ); 47 | 48 | module_boilerplate_ok('lib/App/ClusterSSH.pm'); 49 | 50 | } 51 | 52 | -------------------------------------------------------------------------------- /t/changes.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | unless ( $ENV{RELEASE_TESTING} ) { 4 | plan( skip_all => "Author tests not required for installation" ); 5 | } 6 | 7 | eval 'use Test::CPAN::Changes'; 8 | plan skip_all => 'Test::CPAN::Changes required for this test' if $@; 9 | changes_ok(); 10 | -------------------------------------------------------------------------------- /t/external_cluster_command: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # test script for proving external command for fetching tags works 4 | # 5 | use strict; 6 | use warnings; 7 | use Getopt::Std; 8 | 9 | my $opt = {}; 10 | getopts( 'Lqx', $opt ); 11 | 12 | my %tag_lookup = ( 13 | tag100 => [qw/ host100 /], 14 | tag200 => [qw/ host200 host210 host205 /], 15 | tag300 => [qw/ host300 host350 host325 /], 16 | tag400 => [qw/ tag100 tag200 tag300 host400 host401 /], 17 | ); 18 | 19 | # if we get '-q' option, force an error 20 | if ( $opt->{q} ) { 21 | my $fail; 22 | $fail->cause_death(); 23 | } 24 | 25 | # if we get '-x' option, die with non-0 return code 26 | if ( $opt->{x} ) { 27 | warn 'Forced non-0 exit', $/; 28 | exit 5; 29 | } 30 | 31 | # '-L' means list out available tags 32 | if ( $opt->{L} ) { 33 | print join( ' ', sort keys %tag_lookup ), $/; 34 | exit 0; 35 | } 36 | 37 | my @lookup = @ARGV; 38 | 39 | for (@lookup) { 40 | if ( $tag_lookup{$_} ) { 41 | push( @lookup, @{ $tag_lookup{$_} } ); 42 | $_ = ''; 43 | } 44 | } 45 | 46 | @lookup = grep { $_ !~ m/^$/ } sort @lookup; 47 | 48 | if (@lookup) { 49 | print "@lookup", $/; 50 | } 51 | -------------------------------------------------------------------------------- /t/perltidyrc: -------------------------------------------------------------------------------- 1 | # perltidy to Perl Best Practices standard 2 | -pbp -nst -nse 3 | ## For use in ~/.perltidyrc 4 | # --backup-and-modify-in-place 5 | -------------------------------------------------------------------------------- /t/pod-coverage.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | eval "use Test::Pod::Coverage 1.00"; 6 | plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" 7 | if $@; 8 | 9 | plan skip_all => "Skipping coverage tests" unless $ENV{COVERAGE}; 10 | 11 | all_pod_coverage_ok(); 12 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Ensure a recent version of Test::Pod 8 | my $min_tp = 1.22; 9 | eval "use Test::Pod $min_tp"; 10 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 11 | 12 | all_pod_files_ok(); 13 | -------------------------------------------------------------------------------- /t/range.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use FindBin qw($Bin); 6 | use lib "$Bin/../lib"; 7 | 8 | use Test::More; 9 | use Test::Trap; 10 | use Data::Dump; 11 | 12 | require_ok('App::ClusterSSH::Range') 13 | || BAIL_OUT('Failed to use App::ClusterSSH::Range'); 14 | 15 | my %tests = ( 16 | 'a' => 'a', 17 | 'c{a,b}' => 'ca cb', 18 | 'd{a,b,c}' => 'da db dc', 19 | 'e{0}' => 'e0', 20 | 'f{0..3}' => 'f0 f1 f2 f3', 21 | 'g{0..2,4}' => 'g0 g1 g2 g4', 22 | 'h{0..2,4..6}' => 'h0 h1 h2 h4 h5 h6', 23 | 'i{0..1,a}' => 'i0 i1 ia', 24 | 'j{0..2,a,b,c}' => 'j0 j1 j2 ja jb jc', 25 | 'k{4..6,a..c}' => 'k4 k5 k6 ka kb kc', 26 | 'l{0..2,7..9,e..g}' => 'l0 l1 l2 l7 l8 l9 le lf lg', 27 | 'm{0,1}' => 'm0 m1', 28 | 'n0..2}' => 'n0..2}', 29 | 'host{a,b}-test{1,2}' => 30 | 'hosta-test1 hosta-test2 hostb-test1 hostb-test2', 31 | 32 | # NOTE: the following are not "as expected" in line with above tests 33 | # due to bsd_glob functionality. See output from: 34 | # print join(q{ }, bsd_glob("o{a,b,c")).$/ 35 | 'o{a,b,c' => 'o', 36 | 'p{0..2' => 'p', 37 | 38 | # Reported as bug in github issue #89 39 | 'q-0{0,1}' => 'q-00 q-01', 40 | 'q-0{0..1}' => 'q-00 q-01', 41 | 42 | # expand pure ranges 43 | '{10..12}' => '10 11 12', 44 | 45 | # expand ports 46 | 'lh:{22001..22003}' => 'lh:22001 lh:22002 lh:22003', 47 | 48 | # FQDN's 49 | 'lh{1..3}.dot.com' => 'lh1.dot.com lh2.dot.com lh3.dot.com', 50 | 51 | # IP addresses 52 | '127.0.0.{10..12}' => '127.0.0.10 127.0.0.11 127.0.0.12', 53 | '127.0.{20..22}.1' => '127.0.20.1 127.0.21.1 127.0.22.1', 54 | ); 55 | 56 | my $range = App::ClusterSSH::Range->new(); 57 | isa_ok( $range, 'App::ClusterSSH::Range', 'object created correctly' ); 58 | 59 | for my $key ( sort keys %tests ) { 60 | my $expected = $tests{$key}; 61 | my @expected = split / /, $tests{$key}; 62 | 63 | my $got; 64 | trap { 65 | $got = $range->expand($key); 66 | }; 67 | 68 | is( $trap->stdout, '', "No stdout for scalar $key" ); 69 | is( $trap->stderr, '', "No stderr for scalar $key" ); 70 | is( $trap->leaveby, 'return', "correct leaveby for scalar $key" ); 71 | is( $trap->die, undef, "die is undef for scalar $key" ); 72 | is( $got, "$expected", "expected return for scalar $key" ); 73 | 74 | my @got; 75 | trap { 76 | @got = $range->expand($key); 77 | }; 78 | 79 | is( $trap->stdout, '', "No stdout for array $key" ); 80 | is( $trap->stderr, '', "No stderr for array $key" ); 81 | is( $trap->leaveby, 'return', "correct leaveby for array $key" ); 82 | is( $trap->die, undef, "die is undef for array $key" ); 83 | is_deeply( \@got, \@expected, "expected return for array $key" ) 84 | || diag explain \@got; 85 | } 86 | 87 | done_testing(); 88 | --------------------------------------------------------------------------------