App-ClusterSSH-4.05000755001750001750 012626321255 15336 5ustar00dfergusondferguson000000000000App-ClusterSSH-4.05/Makefile.PL000444001750001750 254312626321255 17451 0ustar00dfergusondferguson000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.39_01 use ExtUtils::MakeMaker; WriteMakefile ( 'PL_FILES' => { 'bin_PL/_build_docs' => [] }, 'INSTALLDIRS' => 'site', 'NAME' => 'App::ClusterSSH', 'EXE_FILES' => [ 'bin/ccon', 'bin/clusterssh_bash_completion.dist', 'bin/crsh', 'bin/csftp', 'bin/cssh', 'bin/ctel' ], 'VERSION_FROM' => 'lib/App/ClusterSSH.pm', 'PREREQ_PM' => { 'Test::Trap' => 0, 'File::Which' => 0, 'Test::Pod' => 0, 'X11::Protocol' => '0.56', 'CPAN::Changes' => '0.27', 'File::Path' => 0, 'Tk' => '800.022', 'File::Slurp' => 0, 'Try::Tiny' => 0, 'Getopt::Long' => 0, 'Test::Pod::Coverage' => 0, 'version' => '0', 'Readonly' => 0, 'Exception::Class' => '1.31', 'Test::Differences' => 0, 'Test::DistManifest' => 0, 'File::Temp' => 0, 'Test::PerlTidy' => 0, 'Locale::Maketext' => 0 } ) ; App-ClusterSSH-4.05/AUTHORS000444001750001750 15112626321255 16520 0ustar00dfergusondferguson000000000000Authors of clusterssh This utility was written by Duncan Ferguson (duncan_ferguson@users.sf.net). $Id$ App-ClusterSSH-4.05/Build.PL000444001750001750 703712626321255 16776 0ustar00dfergusondferguson000000000000use strict; use warnings; use Cwd; use Module::Build; my %project_info = ( tracker => 'https://github.com/duncs/clusterssh/issues', repository => 'http://github.com/duncs/clusterssh', homepage => 'http://github.com/duncs/clusterssh/wiki', ); my $class = Module::Build->subclass( class => "Module::Build::Custom", code => qq{ my \%project_info = ( tracker => '$project_info{tracker}', homepage => '$project_info{homepage}', repository => '$project_info{repository}', ); } . q{ # don't check for errors; 'build_requires' should get this sorted eval { require File::Slurp; require CPAN::Changes; }; sub ACTION_email { my ($self, @args) = @_; # Make sure all tests pass first $self->depends_on("test"); print "Use '--changes ' to define how many to output. Default: 1", $/; my $change_count = $self->args('changes') || 1; my @changes = CPAN::Changes->load( 'Changes' )->releases; if($changes[-1]->date =~ m/^0000/) { die '#' x 40, $/, ' ' x 3, "FATAL: 'Changes' date not updated",$/,'#' x 40, $/; } print $/; print 'Subject: ClusterSSH ', $self->dist_version, ' release', $/; print $/; foreach my $change ( 1 .. $change_count ) { print $changes[ 0 - $change]->serialize; } my $v=$self->dist_version; print <<"EOF"; ========== Home page: $project_info{homepage}, Bug Reports and Issues: $project_info{tracker} Project Repository: $project_info{repository} CPAN release: http://search.cpan.org/~duncs/App-ClusterSSH-$v SF release: http://sourceforge.net/projects/clusterssh/files/2.%20ClusterSSH%20Series%204/App-ClusterSSH-${v}.tar.gz/download ========== EOF return $self; } }, ); my $build = $class->new( meta_merge => { resources => { Repository => [ 'http://clusterssh.git.sourceforge.net/', $project_info{repository}, ], bugtracker => $project_info{tracker}, homepage => $project_info{homepage}, }, }, module_name => 'App::ClusterSSH', license => 'perl', dist_author => q{Duncan Ferguson }, dist_version_from => 'lib/App/ClusterSSH.pm', requires => { 'version' => '0', 'Tk' => '800.022', 'X11::Protocol' => '0.56', 'Locale::Maketext' => 0, 'Exception::Class' => '1.31', 'Try::Tiny' => 0, 'Getopt::Long' => 0, 'File::Path' => 0, }, build_requires => { 'Test::Pod::Coverage' => 0, 'Test::Pod' => 0, 'Test::Trap' => 0, 'Readonly' => 0, 'File::Which' => 0, 'File::Temp' => 0, 'Test::DistManifest' => 0, 'Test::Differences' => 0, 'CPAN::Changes' => 0.27, 'File::Slurp' => 0, 'Test::PerlTidy' => 0, }, recommends => { 'Sort::Naturally' => 0, }, configure_requires => { 'Module::Build' => 0, }, add_to_cleanup => ['App-ClusterSSH-*'], create_makefile_pl => 'traditional', script_files => 'bin', get_options => { changes => { type => '=s' }, }, PL_files => { 'bin_PL/_build_docs' => [], }, ); $build->create_build_script; App-ClusterSSH-4.05/Changes000444001750001750 5202012626321255 17005 0ustar00dfergusondferguson0000000000004.05 2015-11-28 Duncan Ferguson - Change default key_quit from 'Control-q' to 'Alt-q' (Github issue #50) - Amend tests to always use C locale as some error messages are hardcoded in English (Github issue #49) 4.04_01 2015-11-21 Duncan Ferguson - Ensure documentation is generated using same perl as the build (Github issue #45) - Pass '--action' through macro parsing (Github issue #42) - Workaround for glitch in KDE where windows can become unmoveable (Github issue #46) (thanks to Brandon Perkins) - Add in '--quiet | -Q ' option to reduce output in certian scenarios - Add in 'csftp' command 4.04 2015-11-03 Duncan Ferguson - Include bash completion script in distribution (Github issue #29) - Allow re-adding closed session (Github issue #27 - thanks to Andrew Stevenson) - Allow sorting windows in natural order (Github issue #28 - thanks to Andrew Stevenson) - Fix links in metadata files to trackers (Github issue #41) - Fix ctel and ccon not working correctly (Github issue #35) - Amend t/10host.t to use a random hostname to prevent clashes (Github issue #23) - Amend copyright message in README to match all other files for the perl license (Github issue #44) 4.03_06 2015-01-31 Duncan Ferguson - Remove references to 'logmsg' preventing the history window from working (thanks to Andrew Stevenson) 4.03_05 2014-12-20 Duncan Ferguson - Fix options parsing tests picked up via cpantesters on different version of perl 4.03_04 2014-12-12 Duncan Ferguson - Do not use system perl but whatever is found in PATH (to stop breaking perlbrew based builds) - Warn when the configured terminal isn't installed/found - Don't show 'Opening to:' when no servers are given 4.03_03 2014-09-28 Duncan Ferguson - Force tests to have English locale when user has something else set (Github issue: 10) (thanks to Emanuele Tomasi) - Skip permissions check test when run as root as the results are invalid (Github issue: 11) (thanks to Deny Dias) - Ensure config file option for ssh_args is not lost when options is not used on command line (Github issue: 14) - New Send menu option to send a numeric value between 1 and 1024 (thanks to cqexbesd) - Remove all history when history window closed (thanks to Bill Rushmore) 4.03_02 2014-08-10 Duncan Ferguson - Fix behaviour when external cluster command is not defined or doesn't exist 4.03_01 2014-07-09 Duncan Ferguson - Amended host parsing to include alternative IPv6 address port definitions, e.g. 1::2::3::4/5567 - List available external tags with -L option and also add into 'Add Host' in UI [NOTE: Some options have changed!] - Rework options code 4.02_05 0000-00-00 Duncan Ferguson (unreleased) - Add in 'Set all active' and 'Set half active' host menu options (thanks to Andrew Stevenson) 4.02_04 2014-05-17 Duncan Ferguson - Amend 'Changes' file format to match CPAN specs (see CPAN::Changes) - Correct autoclose short option to what is actually used (Github issue 4) (thanks to Simon Fraser) - Fix 'use_all_a_records' option (Github issue: 5) (thanks to Simon Fraser) - Fix 'title' option (thanks to Barry Roberts) - Fix 'Add host or cluster' window to contain cluster names 4.02_03 2014-01-31 Duncan Ferguson - Fix 'File->Show History' (Sf support request 41) - Amend 'tag-file' short option to 'r' to avoid option clash 4.02_02 2014-01-13 Duncan Ferguson - Fixed macros (%u, %s, %h, %n) not doing multiple replacements - Add in key shortcut for username macro (ALT-u) - Add in key shortcut for local hostname macro (ALT-l) - Fix a bug with 'show history' key shortcut - Fix "uninitialised errors in hash element" bug [clusterssh support-requests:#38] - Fixed the default cluster not being opened - Add in toggle for macros 4.02_01 2013-04-16 Duncan Ferguson - Refactured file loading code - Add in 'tags' file handling - Fix bug whereby cluster files were read in multiple times - Add in resolving tags by external command - Fix library path on bin/cssh (Sf bug 3610601) 4.01_05 2013-03-05 Duncan Ferguson - New option (-m, --unique-servers) to remove repeated servers when opening terminals (Thanks to Oliver Meissner) - Drop MYMETA.yml and .json files from the distribution - Do not set default user name to prevent overriding ssh configuration 4.01_04 2013-02-26 Duncan Ferguson - Fixed 'ccon' not calling the correct command (Sf bug 3605002) - Fixed clusters not being defined correctly within the .clusterssh/config file (Sf bug 3605675) 4.01_03 2013-02-15 Duncan Ferguson - Correct documentation for references to $HOME/.clusterssh/config - Re-add user back into the configurartion file - Add in missing newline for some error messages - Allow the path to rsh/ssh/telnet to be defined in the configuration file - Move .csshrc to .csshrc.DISABLED since it should no longer be used - Error emitted when adding a host via the "Hosts" drop-down (Debian bug ID #578208) - Pastes uses a strange keyboard layout (Debian bug ID #364565) - Cope with being invoked by 'clusterssh' (Debian bug ID #644368) - Fix migration of .csshrc when not working as expected (Debian bug ID #673507) - Remove doc references to 'always_tile' as renamed 'window_tiling' (Debian bug ID #697371) - Updated manpage whatis entries (patch by Tony Mancill) - Fix watch line expression to catch 4.x series tarballs (Debian patch LP ID #1076897) - Allow tests to pass successfully when run as root - Fix cssh starting if xterm is not installed (Sf bug 3494988) - Set WM_CLASS on windows to 'cssh' (Sf bug 3187736) 4.01_02 2012-12-09 Duncan Ferguson - Fix logic when using 'autoclose' on the command line or config file - Fix $HOME/.clusterssh/clusters being read in - Fix 'ctel', 'crsh' and 'ccon'so they work as expected 4.01_01 2011-12-09 Duncan Ferguson - Include missing files from release tarballs 4.01_00 2011-12-03 Duncan Ferguson - Start switching code to use Exception::Class - Moved config file from $HOME/.csshrc file to $HOME/.clusterssh directory - Rework config handling into a module - Rework cluster handling into a module - Added 'autoclose' functionality - see docs - Allow "-a 'cmd ; cmd'" to work for multiple remote commands 4.00_11 2011-07-28 Duncan Ferguson - Fix '-l ' option (SF bug 3380675) 4.00_10 2011-07-08 Duncan Ferguson - Fix 'uninitialised error' message 4.00_09 2011-06-30 Duncan Ferguson - Cater for missing 'pod2text' command (Thanks to Sami Kerola) - Fix 'uninitialised variable' error - Added 'ccon' command (Thanks to Brandon Perkins) 4.00_08 2011-04-01 Duncan Ferguson - Amend all L links to prevent build breakage on cygwin (Sf bug 3115635) 4.00_07 2011-01-24 Duncan Ferguson - Fix for parsing config files with empty values (Stefan Steiner) - Reinstate acting on '-l username' option (reported by Ryan Brown) 4.00_06 2010-09-20 Duncan Ferguson - Fix test error on 5.8.8 (reported by Wei Wang) - Added '--list', '-L' to list available cluster tags (idea from Markus Manzke) - Fix terminal size only set on last windows (Sf bug 3061999) - Added '--use_all_a_records' (Simon Fraser) 4.00_05 2010-06-20 Duncan Ferguson - Tidy up pod for whatis errors - Amend copyright years and text to be consistent - Include missing buld prereq (Test::Trap) - Correct '--font, -f' in cssh documentation - Thanks to Tony Mancill for reporting these errors 4.00_04 2010-06-20 Duncan Ferguson - Update MANIFEST file to ensure all correct files are included in release 4.00_03 2010-06-20 Duncan Ferguson - Fix silly type in code/tests 4.00_02 2010-06-19 Duncan Ferguson - Add in bugtracker and homepage resources to Build.PL file - Bring new module App::ClusterSSH::Host into play for parsing host strings - Patch to override font used on command line (Roland Rosenfeld) - Put options in cssh pod into alphabetical order 4.00_01 2010-01-08 Duncan Ferguson - Remove GNU tools and switch to Perl module layout using Module::Build 3.29 0000-00-00 Duncan Ferguson (unreleased) - Handle hostnames containing % properly (Debian bug 543368) - Thanks to Tony Mancill for the patch 3.28 2009-12-19 Duncan Ferguson - Look for usernames when adding clusters - Thanks to Kristian Lyngstol for the patch - Allow username@cluster to override all usernames in the cluster - Account for multiple host definitions within ssh configuration file - Thanks to anonymous for the patch - Allow for long line continuation in config files with a backslash - Thanks to Mike Loseke for the patch - Improve binary search to - ignore directories of the same name, and - always search for the binary if it is not fully qualified - Thanks to Ian Marsh for the patch - Always use the given host name, not the resolved host name, when opening the ssh connection (Debian bug 533406) 3.27 2009-09-24 Duncan Ferguson - Add in list of clusters to 'Add Host' window - thanks for Stanislas Rouvelin for the idea - Fix bug where unresolvable host stopped program running - thanks to Sami Kerola - Add in config for auto-tearoff of send and host menus - thanks to James Chernikov for the idea - Add in send menu xml definition file - thanks to James Chernikov for the idea 3.26_1 2009-06-02 Duncan Ferguson - Allow user to set a different ConnectTimeout and -o string (Tony Mancill) - Fix warning from 'mandb' (Tony Mancill) - Continue connecting to unresolvable hosts (debian bug 499935) (Tony Mancill) - Correct bug with unset default ports (Tony Mancill) - Rearrange pod documentation to remove extraenous comment (Tony Mancill) - Cope better with IPv6 addresses - Fix bug with passing arguments from command line to comms method binary - Rework defaultport code - Add new "-a 'command'" option for running a command in each terminal - Fix bug with some host lookups failing - Set window hints on terminals slightly differently to help with tiling - Reserve 5 pixels on top and left hand side of terminals for better tiling - Increase reserve of screen from bottom from 40 pixels to 60 - Better notes in docs for screen/terminal reserving - Minor fixup to docs formatting - Correct pasting mechanism into control window - Allow use of long options (swap Getopt::Std to Getopt::Long) - Remove deprecated '-i' option - Deprecate -d and -D, replaced with --debug - Allow for configurable max number of hosts within hosts menu before starting a new column - see .csshrc doc for "max_host_menu_items". This is until Tk allows for scrollable menus - Amend default key_addhost from 'Control-plus' to 'Control-Shift-plus' - Add in a 'default' cluster tag, used when no tags provided on command line - Fix Alt-n pasting in a resolved hostname instead of the connection hostname - Disabled unmapping code until such time as a better way of doing it exists - this is due to virtual desktop change triggering a retile 3.25_1 2009-03-26 Duncan Ferguson - Add patch from David F. Skoll for adding colour to terminals - Apply fix from Bogdan Pintea for DNS failing to resolve IPs - Allow the configuration files to be symlinks (debian bug 518196) - Add an 'EXAMPLES' section to the cssh documentation - List options alphabetically in documentation - Apply patch from Gerfried Fuchs/Tony Mancill for ports on the command line 3.24_1 2008-11-14 Duncan Ferguson - Do not attempt to re-resolve IP addresses - Apply patch from Dan Wallis - Add '-C ' command to load in specific config file - Typo correct in pod - Cope with random/strange config files better - Correct some minor typos - Create the .csshrc file if it doesnt already exist and amend pod - Amend host menu items to be a little more descriptive - Remove 'Catpure Terminal' from Hosts menu as it doesnt do anything useful 3.23_1 2008-01-23 Duncan Ferguson - Apply bugfix supplied by Jima - Ensure loading of hosts from user ssh config file is case insensitive 3.22_1 2008-01-23 Duncan Ferguson - Update X resources class to allow use of terms other than XTerm - Apply patch from Harald Weidner to stop error messages in Debian Etch - Add in key shortcut (alt-h) to toggle history window - Tidy up pod a little to highlight notes better - Check terminal_font config for quotes and remove - Enable use of "configure --sysconfdir=", defaults to /etc - Revise host checking algorithm to take ssh_config files into account - Revise username check used as part of host id to accept more chars - Correct year value for previous two entries from 2008 to 2007 3.21_1 2007-11-28 Duncan Ferguson - Implement a basic history window in the console (option -s) - Fixed bug whereby username@ wasn't being used correctly 3.20_1 2007-11-26 Duncan Ferguson - Move source repository from CVS to SVN on sourceforge - Remove last digit of version number since not required with SVN - Add in host menu option to close inactive windows - Apply bugfixes suppled by Tony Mancill - reset xrm switch in terminal_args - prevent warning messages being printed when keysyms arent found - fixes for fvwm - chekc for child process before sending kill - Slight rewording of man page - Add in option to use telnet as comms command (use 'ctel' to invoke script) - Run through perltidy -b -i=2 - Appy patches from Klaus Ethgen - Client dies when cannot write to pipe - Sleeping and flushing in window manager to allow time to draw windows - Fix pipe reading to not use undefined values - Apply patches from Nicolas Simonds - allow colons in hostnames - allow -o option as per man page - Apply patch from Peter Palfrader - improvement to finding binaries - Allow font to be specified on the command line - Check for errors around key data gathering - Add in 'extra_cluster_file' to csshrc 3.19.1_1 2006-07-24 Duncan Ferguson - Below is an abridged version of changes - see CVS for more information - Check for failure to connect to X session - Totally rework character mapping and events to cope with non-QWERTY keyboards - Rework pasting code to cope with non-QWERTY charatcters - Manpage/help doc updates and corrections - Check for missing definitions for cluster tags in .csshrc - Run through perltidy -b -i=2 - Apply patch to add in optional port information from D. Dumont - Amend hotkey code to not pick up - as default clientname shortcut - Alter repeat function to improve efficiency - Rework retiling code - Add "-e " to evaluate terminal and communcation methods - Add in toggle option on hosts menu - Fix check in find_binary to ensure one is actually found - Search $PATH and other standard places for binaries incase $PATH is incomplete - Amend code to allow getting help when no X display available - Allow override of both key and mouse paste key sequences - Added icons and desktop file - Amended clusterssh.spec to cope with icons and desktop file - Improve cluster file import efficiency as was taking faaar too long previously - Fixed bug whereby when pid's of the xterm changes records were not updated - Do not die when pipe open fails, but continue as others may be connected - Remove code that breaks the minimize/maximise stuff; - Catch X button presses on title bar to close all windows correctly - Delay map event capture at program start to avoid infinite loop - Fix execvp error on Solaris 10 3.18.1_1 2005-11-28 Duncan Ferguson - Correct mask value for backtick (grave) character - Add more logging for debug mode - Amend indentation - Rerun through perltidy - Improve cluster file import efficiency as was taking faaar too long previously - Fixed bug whereby when pid's of the xterm changes records were not updated - Do not die when pipe open fails, but continue as others may be connected - Remove code that breaks the minimize/maximise stuff; - Catch X button presses on title bar to close all windows correctly - Delay map event capture at program start to avoid infinite loop - Fix execvp error on Solaris 10 - Update to man pages 3.17.1 2005-06-24 Duncan Ferguson - Allow _'s in paste text correctly - Bugfix minimise/maximise again - Run through "perltidy -i=4 -ce" - Unmap all windows in one go instead of one at a time when retiling - Add + doc 'console_position' - Maintain user position of console between maps (i.e. tell window manager not to move it) - Note that ssh options are for OpenSSH not for any other ssh version 3.16.1 2005-06-13 Duncan Ferguson - Allow ignoring of unresolved hosts (i.e. if hostname aliased in ssh config file) 3.15.1 2005-06-09 Duncan Ferguson - Add and document "-c " - Add and document "-l " - Add and document "-o " - Document "-t " - Set controlled terminals to have user set size & position (WM_SIZE_HINTS) - Speed up initial terminal openings - Remove all key bindings from drop down menus (conflicts with emacs and can all be done by other hotkeys anyhow) - Allow individual hotkeys to be disabled, instead of all-or-nothing - Updates to POD - Update retile code to avoid flickering windows (& also fix cygwin bug) - Rename -t to -T to match previous series option - Added in -t to modify cmd line args for terminals 3.14.1 2005-06-04 Duncan Ferguson <duncan_ferguson@user.sf.net> - first cut at terminal opening speed up 3.13.1 2005-05-20 Duncan Ferguson <duncan_ferguson@user.sf.net> - Bugfix for whitespace in config files (missing a char from regexp) - Allow for minimising/maximising all windows when done on console 3.12.1 2005-05-19 Duncan Ferguson <duncan_ferguson@user.sf.net> - Bugfix for shifted non-alphanumeric keyboard chars not being pasted correctly - Marked version number with 3rd digit to signify beta releases 3.11 2005-05-18 Duncan Ferguson <duncan_ferguson@user.sf.net> - Remove trailing whitespace from config file lines - Prevent paste events being sent to non-active clients - Allow paste events to send capitalised letters 3.10 2005-05-17 Duncan Ferguson <duncan_ferguson@user.sf.net> - fix for moving atom numbers in font info 3.9 2005-05-11 Duncan Ferguson <duncan_ferguson@user.sf.net> - Allow multiple hosts or tags in the "Add Host" text widget - Retile all windows (if set) after adding a host - Do not automatically send a return after hostname (Alt-n) - Fix bug with sending read hostname instead of internal unique host name (Alt-n) - Fix bug whereby cannot start cssh without any hosts on cmd-line - Fix bug where client name was sent to inactive clients - Fix bug whereby 0's in sent text were ignored 3.8 2005-05-09 Duncan Ferguson <duncan_ferguson@user.sf.net> - Remove the need for xlsfonts (perform function by X window calls instead) - Debug level output changes - Ensure windows are overlapping in the right places, instead of any order - Create config section on window decorations (i.e. title & scroll bars) 3.7 2005-05-05 Duncan Ferguson <duncan_ferguson@user.sf.net> - Found ConfigureWindow instead of ResizeMoveWindow 3.6 2005-05-05 Duncan Ferguson <duncan_ferguson@user.sf.net> - Lots of work on window tiling - to fall at last hurdle (No XResizeMoveWindow) - Documentation updates - Allow -u ouput when binaries havnt been found - Start coding for capturing an existing terminal window - Rebuild hosts menu when all hosts checked, not when each host checked - Change debug message output level of keysyms - Cater for config of no tiling, but allow to retile in console window anyhow 3.5 2005-05-03 Duncan Ferguson <duncan_ferguson@user.sf.net> - Remove some old (commented out) code - Remove some (unnecessary) debug code - Start coding for window tiling - Modify find_binary function to make it more portable - Output internal vars in "-u -d" - Small mods to docs to take account of all of the above 3.4 2005-04-26 Duncan Ferguson <duncan_ferguson@user.sf.net> - Changed order of "use POSIX" to put :sys_wait_h first to avoid chance of hitting known issue - Allow for running from cvs dir in config{comms} - Add "ConnectTimeout=10" to default ssh options - Add further debug info - Add check to ensure hostname can be resolved before attempting connection - Modigy zombie reaping to prevent hand on unconnected cx term closing - Add "autoquit" feature to close ClusterSSH after last client window closes - Also produce man page and include as part of install 3.3 2005-04-10 Duncan Ferguson <duncan_ferguson@user.sf.net> - src/cssh.pl: Rewritten from scratch - Set up to use Gnu Autotools ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/META.yml������������������������������������������������������������������������000444��001750��001750�� 3567�12626321255� 16757� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������--- abstract: 'A container for functions of the ClusterSSH programs' author: - 'Duncan Ferguson <duncan_j_ferguson@yahoo.co.uk>' build_requires: CPAN::Changes: '0.27' File::Slurp: '0' File::Temp: '0' File::Which: '0' Readonly: '0' Test::Differences: '0' Test::DistManifest: '0' Test::PerlTidy: '0' Test::Pod: '0' Test::Pod::Coverage: '0' Test::Trap: '0' configure_requires: Module::Build: '0' dynamic_config: 1 generated_by: 'Module::Build version 0.3901, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: App-ClusterSSH provides: App::ClusterSSH: file: lib/App/ClusterSSH.pm version: '4.05' App::ClusterSSH::Base: file: lib/App/ClusterSSH/Base.pm version: '0.02' App::ClusterSSH::Cluster: file: lib/App/ClusterSSH/Cluster.pm version: '0.01' App::ClusterSSH::Config: file: lib/App/ClusterSSH/Config.pm version: '0.02' App::ClusterSSH::Getopt: file: lib/App/ClusterSSH/Getopt.pm version: '0.01' App::ClusterSSH::Helper: file: lib/App/ClusterSSH/Helper.pm version: '0.02' App::ClusterSSH::Host: file: lib/App/ClusterSSH/Host.pm version: '0.03' App::ClusterSSH::L10N: file: lib/App/ClusterSSH/L10N.pm App::ClusterSSH::L10N::en: file: lib/App/ClusterSSH/L10N/en.pm recommends: Sort::Naturally: '0' requires: Exception::Class: '1.31' File::Path: '0' Getopt::Long: '0' Locale::Maketext: '0' Tk: '800.022' Try::Tiny: '0' X11::Protocol: '0.56' version: '0' resources: Repository: - http://clusterssh.git.sourceforge.net/ - http://github.com/duncs/clusterssh bugtracker: https://github.com/duncs/clusterssh/issues homepage: http://github.com/duncs/clusterssh/wiki license: http://dev.perl.org/licenses/ version: '4.05' x_serialization_backend: 'CPAN::Meta::YAML version 0.016' �����������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/README��������������������������������������������������������������������������000444��001750��001750�� 3410�12626321255� 16351� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH The is the Perl application bundle for ClusterSSH (a.k.a cssh), formally a GNU tools based project. ClusterSSH is a tool for making the same change on multiple servers at the same time. The 'cssh' command opens an administration console and an xterm to all specified hosts. Any text typed into the administration console is replicated to all windows. All windows may also be typed into directly. This tool is intended for (but not limited to) cluster administration where the same configuration or commands must be run on each node within the cluster. Performing these commands all at once via this tool ensures all nodes are kept in sync. For more information, go to https://github.com/duncs/clusterssh INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc cssh or (if your MANPATH is set up appropriately) man cssh You can also look for information at: Web site and HitHub project page https://github.com/duncs/clusterssh Project support area https://github.com/duncs/clusterssh/issues AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/App-ClusterSSH CPAN Ratings http://cpanratings.perl.org/d/App-ClusterSSH Search CPAN http://search.cpan.org/dist/App-ClusterSSH/ COPYRIGHT AND LICENCE Copyright (C) 1999-2015 Duncan Ferguson This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/TODO����������������������������������������������������������������������������000444��001750��001750�� 2604�12626321255� 16165� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Overview of tasks ================= Config file =========== Convert from file ~/.cssrch to directory ~/.clusterssh For conversion process - clusters in .csshrc should be placed into 'default.cluster' - all other config should go into 'config' - create default menu file New feature - if cssh -s symlinked to c_xxx then search for xxx as a cluster file in .clutersshrc and open that Getopts usage ============= Set up similar to Nagios::Plugin where Getopts::Long is subclassed Sort out docs too Add in '-l' to list all available tags Add in '-l <tag>' to list all hosts for the given tag Idea from Markus Manzke Change way commands generated ============================= Each script file (cssh, crsh, ctel, ccon, cscp, crsync) should define how the command is created/used and also none-common options # Something like the following (needs refinement): $app->setup_command( "ssh %PORT% %USER% %HOSTNAME%", { %PORT% => [ $app->getopt->port, "-p %PORT%" ], %USER% => [ $app->getopt->username, "-l %USER%" ], } ) Change way terminal windows are created ======================================= Set up terminal windows in Tk to embedd termainl session into it, such as with xterm xterm -wid <wid> .... This may limit to terminal thats can reparent into a given window id though. See also: http://www.perlmonks.org/?node_id=359764 http://www.perlmonks.org/?node_id=643221 ����������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/THANKS��������������������������������������������������������������������������000444��001750��001750�� 1502�12626321255� 16404� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������ClusterSSH THANKS file ClusterSSH has originally been written by Duncan Ferguson. Many people further contributed to ClusterSSH by reporting problems, suggesting various improvements or submitting actual code. Here is a list of these people. Help me keep it complete and exempt of errors. Tony Mancill David Gardner Hans-Joachim Hoetger Gavin Brock Bren Viren Rob Petty Jason (jklap) Cyril Bouthors Chris Trahman Olivier Beyssac Rob Dawson Steve Roome D. Dumont Dan Wallis Jima Harald Weidner Klaus Ethgen Nicolas Simonds Peter Palfrader David F. Skoll Bogdan Pintea Gerfried Fuchs Stanislas Rouvelin Sami Kerola Kristian Lyngstol Mike Loseke Ian Marsh Roland Rosenfeld Wei Wang Markus Manzke Simon Fraser Stefan Steiner Ryan Brown Brandon Perkins Oliver Meissner Andrew Stevenson (cqexbesd) Emanuele Tomasi Deny Dias Bill Rushmore ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/MANIFEST.SKIP�������������������������������������������������������������������000444��001750��001750�� 300�12626321255� 17342� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������^App-ClusterSSH-.* .*\.bak$ ^bin/ ^blib/ ^_build/ ^Build$ ^cover_db/ ^.git/ ^.gitignore ^Makefile$ ^Makefile.old$ ^MANIFEST\.bak$ MYMETA.json MYMETA.yml pm_to_blib .*\.swp$ ^TOAD$ ^WIP_TASKS$ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/META.json�����������������������������������������������������������������������000444��001750��001750�� 5635�12626321255� 17125� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������{ "abstract" : "A container for functions of the ClusterSSH programs", "author" : [ "Duncan Ferguson <duncan_j_ferguson@yahoo.co.uk>" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.3901, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "App-ClusterSSH", "prereqs" : { "build" : { "requires" : { "CPAN::Changes" : "0.27", "File::Slurp" : "0", "File::Temp" : "0", "File::Which" : "0", "Readonly" : "0", "Test::Differences" : "0", "Test::DistManifest" : "0", "Test::PerlTidy" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Trap" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0" } }, "runtime" : { "recommends" : { "Sort::Naturally" : "0" }, "requires" : { "Exception::Class" : "1.31", "File::Path" : "0", "Getopt::Long" : "0", "Locale::Maketext" : "0", "Tk" : "800.022", "Try::Tiny" : "0", "X11::Protocol" : "0.56", "version" : "0" } } }, "provides" : { "App::ClusterSSH" : { "file" : "lib/App/ClusterSSH.pm", "version" : "4.05" }, "App::ClusterSSH::Base" : { "file" : "lib/App/ClusterSSH/Base.pm", "version" : "0.02" }, "App::ClusterSSH::Cluster" : { "file" : "lib/App/ClusterSSH/Cluster.pm", "version" : "0.01" }, "App::ClusterSSH::Config" : { "file" : "lib/App/ClusterSSH/Config.pm", "version" : "0.02" }, "App::ClusterSSH::Getopt" : { "file" : "lib/App/ClusterSSH/Getopt.pm", "version" : "0.01" }, "App::ClusterSSH::Helper" : { "file" : "lib/App/ClusterSSH/Helper.pm", "version" : "0.02" }, "App::ClusterSSH::Host" : { "file" : "lib/App/ClusterSSH/Host.pm", "version" : "0.03" }, "App::ClusterSSH::L10N" : { "file" : "lib/App/ClusterSSH/L10N.pm" }, "App::ClusterSSH::L10N::en" : { "file" : "lib/App/ClusterSSH/L10N/en.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/duncs/clusterssh/issues" }, "homepage" : "http://github.com/duncs/clusterssh/wiki", "license" : [ "http://dev.perl.org/licenses/" ], "x_Repository" : [ "http://clusterssh.git.sourceforge.net/", "http://github.com/duncs/clusterssh" ] }, "version" : "4.05", "x_serialization_backend" : "JSON::PP version 2.27203" } ���������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/MANIFEST������������������������������������������������������������������������000444��001750��001750�� 1570�12626321255� 16627� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������AUTHORS bin_PL/_build_docs bin_PL/ccon bin_PL/clusterssh_bash_completion.dist bin_PL/crsh bin_PL/cscp.x bin_PL/csftp bin_PL/cssh bin_PL/ctel Build.PL Changes lib/App/ClusterSSH/Base.pm lib/App/ClusterSSH/Cluster.pm lib/App/ClusterSSH/Config.pm lib/App/ClusterSSH/Getopt.pm lib/App/ClusterSSH/Helper.pm lib/App/ClusterSSH/Host.pm lib/App/ClusterSSH/L10N/en.pm lib/App/ClusterSSH/L10N.pm lib/App/ClusterSSH.pm Makefile.PL MANIFEST MANIFEST.SKIP META.json META.yml README t/00-load.t t/01l10n.t t/02base.t t/05getopts.t t/10host_ssh_config t/10host.t t/15config.t t/15config.t.file1 t/15config.t.file2 t/15config.t.file3 t/20helper.t t/30cluster.cannot_read t/30cluster.file1 t/30cluster.file2 t/30cluster.file3 t/30cluster.t t/30cluster.tag1 t/80clusterssh.t t/boilerplate.t t/changes.t t/external_cluster_command THANKS t/manifest.t TODO t/perltidy.t t/perltidyrc t/pod-coverage.t t/pod.t ����������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL��������������������������������������������������������������������������000755��001750��001750�� 0�12626321255� 16501� 5����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/cssh���������������������������������������������������������������������000555��001750��001750�� 442�12626321255� 17504� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use FindBin; use lib $FindBin::Bin. '/../lib'; use lib $FindBin::Bin. '/../lib/perl5'; use App::ClusterSSH; my $app = App::ClusterSSH->new(); $app->options->add_common_ssh_options; $app->options->add_common_session_options; $app->run(); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/_build_docs��������������������������������������������������������������000555��001750��001750�� 2104�12626321255� 21027� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use FindBin qw($Bin $Script); chdir $Bin || die "Unable to chdir into $Bin: $!"; my $bindir="$Bin/../bin"; if(! -d $bindir) { mkdir $bindir || die "Could not mkdir $bindir: $!"; } print "Using perl binary: $^X",$/; print "Using perl version $^V",$/; for my $source (glob("*")) { my $dest="$bindir/$source"; next if($source =~ m/$Script/); next if($source =~ m/\.x$/); print "Generating: $source",$/; if(-f $dest) { chmod(0777, $dest) || die "Could not chmod $dest for removing: $!"; } open(my $sfh, '<', $source) || die "Could not open $source for reading: $!"; open(my $dfh, '>', $dest ) || die "Could not open $dest for writing: $!"; print $dfh $_ while(<$sfh>); close($sfh); if($source ne "clusterssh_bash_completion.dist") { print $dfh "\n\n__END__\n\n"; my $pod= qx{ $^X ./$source --generate-pod }; die "Failed to generate pod" if($?); print $dfh $pod; } close($dfh); chmod(0555, $dest) || die "Could not chmod $dest: $!"; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/ctel���������������������������������������������������������������������000555��001750��001750�� 314�12626321255� 17471� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use FindBin; use lib $FindBin::Bin. '/../lib'; use lib $FindBin::Bin. '/../lib/perl5'; use App::ClusterSSH; my $app = App::ClusterSSH->new(); $app->run(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/csftp��������������������������������������������������������������������000555��001750��001750�� 442�12626321255� 17663� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use FindBin; use lib $FindBin::Bin. '/../lib'; use lib $FindBin::Bin. '/../lib/perl5'; use App::ClusterSSH; my $app = App::ClusterSSH->new(); $app->options->add_common_ssh_options; $app->options->add_common_session_options; $app->run(); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/crsh���������������������������������������������������������������������000555��001750��001750�� 442�12626321255� 17503� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use FindBin; use lib $FindBin::Bin. '/../lib'; use lib $FindBin::Bin. '/../lib/perl5'; use App::ClusterSSH; my $app = App::ClusterSSH->new(); $app->options->add_common_ssh_options; $app->options->add_common_session_options; $app->run(); 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/cscp.x�������������������������������������������������������������������000444��001750��001750�� 13247�12626321255� 20006� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/bin/sh #LICENSE: GNU GPL version 2 #Author: JT Moree: moreejt@pcxperience.com #Copyright: Kahala Corp. 2006 #Date: 20061213 # # $URL$ # $Id$ # VERSION='$Revision$ ($Date$)' PROGRAM=`basename $0` DEBUG=n ETC=/etc/clusterscp CONF=/etc/clusters RC=/etc/clusterscprc GRP= COMMENT= DEST= SYSLOG=0 usage() { cat <<FOO $PROGRAM v. $VERSION Usage: $PROGRAM [options] -C<cluster> file1 file2 file3 . . . or $PROGRAM [options] -H<user@host> file1 file2 file3 . . . This program copies files to multiple remote machines using ssh and scp and can log the action. LICENSE Released under the terms of the GNU GPL version 2 OPTIONS -C server cluster(s) to scp to. see GROUPS/CLUSTERS -D destination directory on target servers -d Debug mode -H scp to this one host (format user@host) -h help -f Use this config file for groups/clusters. Use this to override the use of clusterssh config in /etc/clusters. -t comment to describe the action Make sure to use quotes when there are spaces in your params. GROUPS/CLUSTERS This script uses scp to copy files to the specified destination of each server in a server cluster. A server cluster is specified in a file (usually $CONF) in the format: <clustername> <user>@<server> <user>@<server> . . . . See clusterssh for more info Each cluster may also have custom configurations specified in a file ending with .cfg. ie. servers A, B, and C are in group FOO. There is a line in file $CONF FOO root@A root@B root@C and potentially another file $ETC/FOO.cfg CONFIG FILES In the .cfg file vars can be set in the form of bash/sh vars: LOG=/root/Documentation/changelog LOGGING to SYSLOG The log string will use the format 20060111 11:11:11 user clusterscp:cluster:comment: <files> The script attempts to use logger (syslog) on each target machine. To turn this off set the SYSLOG=0 config in $RC or in the .cfg for that cluster. LOGGING to a CUSTOM LOG The log string will use the format 20060111 11:11:11 user clusterscp:group:comment: <files> The .cfg file can have a parameter set LOG=/path/to/log. If so, it logs the action to that file by appending to the end of it. SSH w/o PASSWORDS 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. FOO } copy_files() { copy_files_TARGET=$1 copy_files_DEST=$2 shift 2 CHECK=`echo $copy_files_TARGET | grep '@'` if [ -z "$CHECK" ] ; then #target does not have format of user@host. perhaps it is another cluster? #check to see if a cluster matches this name and process it copy_cluster "$copy_files_TARGET" "$copy_files_DEST" $@ else if [ "$DEBUG" = "y" ] ; then echo scp $@ $copy_files_TARGET:$copy_files_DEST >/dev/null else scp $@ $copy_files_TARGET:$copy_files_DEST >/dev/null fi if [ "$?" -eq 0 ] ; then echo "$copy_files_TARGET: OK" if [ $SYSLOG -eq 1 ] ; then if [ "$DEBUG" = "y" ] ; then echo ssh $copy_files_TARGET "logger -t$PROGRAM -pauth.info '$LOGSTRING'" else ssh $copy_files_TARGET "logger -t$PROGRAM -pauth.info '$LOGSTRING'" fi fi if [ -n "$LOG" ] ; then if [ "$DEBUG" = "y" ] ; then echo ssh $copy_files_TARGET "echo '`date +"%Y%m%d %H:%M:%S"` $LOGSTRING' >> $LOG" else ssh $copy_files_TARGET "echo '`date +"%Y%m%d %H:%M:%S"` $LOGSTRING' >> $LOG" fi fi else echo "$copy_files_TARGET: ERROR" fi fi } copy_cluster() { copy_cluster_CLUSTER=$1 copy_cluster_DEST=$2 shift 2 copy_cluster_SKIP= #to skip the first word in the line copy_cluster_COUNT=0 for copy_cluster_TARGET in `egrep "^$copy_cluster_CLUSTER" $CONF` ; do if [ -z "$copy_cluster_SKIP" ] ; then copy_cluster_SKIP=n else copy_files "$copy_cluster_TARGET" "$copy_cluster_DEST" $@ fi copy_cluster_COUNT=$(($copy_cluster_COUNT + 1)) done if [ 0 -eq $copy_cluster_COUNT ] ; then echo "Warning! No cluster found with name $copy_cluster_CLUSTER" >&2 fi } #source global config file if [ -f $RC ] ; then . $RC fi while getopts C:dD:f:hH:t:vx OPTION do case "$OPTION" in h) usage ; exit 1 ;; v) echo $VERSION; exit 1 ;; x) set -x; DEBUG=y; shift 1 ;; C) GRP=$OPTARG; shift 2 ;; d) DEBUG=y; shift 1 ;; D) DEST=$OPTARG; shift 2 ;; f) CONF=$OPTARG; shift 2 ;; H) HOST=$OPTARG; shift 2 ;; t) COMMENT=$OPTARG; shift 2 ;; *) echo ; echo "!!!!!!Error. Invalid option given" >&2; echo ; usage; exit 1 ;; esac done if [ -z "$GRP" ] && [ -z "$HOST" ] ; then usage echo echo "Error. You must specify a cluster or a host (-C or -H)!" >&2 exit 1 fi #do a sanity check on all files if [ 0 -eq $# ] ; then usage echo "Error. No files specified." >&2 exit 1 fi for f in $@ ; do if [ ! -r $f ] ; then echo "Error reading file $f. Aborting transaction." >&2 exit 1 fi #build file list for log FILES="${FILES} `basename $f`" done if [ -n "$HOST" ] ; then CHECK=`echo $HOST | grep '@'` if [ -z "$CHECK" ] ; then #target does not have format of user@host. perhaps it is another cluster? echo "Error! -H option must use format user@host: '$HOST' is invalid." >&2 echo "If this is a cluster use the -C option." >&2 exit 1 fi #build log string LOGSTRING="$USER $PROGRAM:$COMMENT:$DEST $FILES" copy_files "$HOST" "$DEST" $@ fi if [ -n "$GRP" ] ; then #build log string LOGSTRING="$USER $PROGRAM $GRP:$COMMENT:$DEST $FILES" if [ -r $ETC/$GRP.cfg ] ; then . $ETC/$GRP.cfg fi if [ -z "$SYSLOG" ] ; then SYSLOG=0 fi if [ "$DEBUG" = "y" ] ; then echo "cluster IS '$GRP'" fi copy_cluster "$GRP" "$DEST" $@ fi ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/bin_PL/ccon���������������������������������������������������������������������000555��001750��001750�� 763�12626321255� 17474� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use FindBin; use lib $FindBin::Bin. '/../lib'; use lib $FindBin::Bin. '/../lib/perl5'; use App::ClusterSSH; my $app = App::ClusterSSH->new(); #$app->options->add_common_ssh_options; #$app->options->add_common_session_options; $app->add_option( spec => 'master|M=s', help => $app->loc("The console client program polls master as the primary server, rather than the default set at compile time (typically ``console'')."), ); $app->run(); 1; �������������App-ClusterSSH-4.05/bin_PL/clusterssh_bash_completion.dist������������������������������������������000444��001750��001750�� 5463�12626321255� 25160� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- mode: shell-script; sh-basic-offset: 8; indent-tabs-mode: t -*- # ex: ts=8 sw=8 noet filetype=sh # # cssh(1) completion by Aaron Spettl <aaron@spettl.de>, adapted from the # Debian GNU/Linux dput(1) completion by Roland Mas <lolando@debian.org> # # On Debian (and Debian based distributions) drop this file into # /etc/bash_completion.d # and source the /etc/bash_completion script - or just restart bash. have cssh && _cssh() { local cur prev options paroptions clusters extra_cluster_file_line clusters_line extra_cluster_file COMPREPLY=() cur=${COMP_WORDS[COMP_CWORD]} prev=${COMP_WORDS[COMP_CWORD-1]} # all options understood by cssh options='-c --cluster-file -C --config-file --debug -e --evaluate \ -g --tile -G --no-tile -h --help -H --man -l --username \ -o --options -p --port -q --autoquit -Q --no-autoquit \ -s --show-history -t --term-args -T --title \ -u --output-config -v --version' # find the extra cluster file line in the .csshrc or, alternatively, /etc/csshrc extra_cluster_file_line="`grep '^[[:space:]]*extra_cluster_file' $HOME/.csshrc 2> /dev/null`" [ -z "$extra_cluster_file_line" ] && extra_cluster_file_line="`grep '^[[:space:]]*extra_cluster_file' /etc/csshrc 2> /dev/null`" # find the clusters line in the .csshrc or, alternatively, /etc/csshrc clusters_line="`grep '^[[:space:]]*clusters' $HOME/.csshrc 2> /dev/null`" [ -z "$clusters_line" ] && clusters_line="`grep '^[[:space:]]*clusters' /etc/csshrc 2> /dev/null`" # extract the location of the extra cluster file extra_cluster_file="`echo $extra_cluster_file_line | cut -f 2- -d '='`" [ -n "$extra_cluster_file" ] && extra_cluster_file="`eval echo $extra_cluster_file`" # TODO: don't use eval to expand ~ and $HOME # get the names of all defined clusters clusters=$( { [ -n "$clusters_line" ] && echo "$clusters_line" | cut -f 2- -d '=' | tr "$IFS" "\n" || /bin/true [ -n "$extra_cluster_file" ] && sed -e 's/^\([a-z0-9.-]\+\).*$/\1/i' "$extra_cluster_file" 2> /dev/null || /bin/true sed -e 's/^\([a-z0-9.-]\+\).*$/\1/i' /etc/clusters 2> /dev/null || /bin/true } | sort -u) # use options and clusters for tab completion, except there isn't yet # at least one character to filter by # reason: don't show options if the user types "cssh <tab><tab>" paroptions="$clusters" [ -n "$cur" ] && paroptions="$paroptions $options" case $prev in --cluster-file|-c|--config-file|-C) COMPREPLY=( $( compgen -o filenames -G "$cur*" ) ) ;; *) COMPREPLY=() # also use ssh hosts for tab completion if function _known_hosts is present [ "`type -t _known_hosts`" = "function" ] && _known_hosts -a COMPREPLY=( "${COMPREPLY[@]}" $( compgen -W "$paroptions" | grep "^$cur") ) ;; esac return 0 } [ "$have" ] && complete -F _cssh cssh crsh ctel �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib�����������������������������������������������������������������������������000755��001750��001750�� 0�12626321255� 16104� 5����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App�������������������������������������������������������������������������000755��001750��001750�� 0�12626321255� 16624� 5����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH.pm�����������������������������������������������������������000444��001750��001750�� 212720�12626321255� 21362� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH; use 5.008.004; use warnings; use strict; use version; our $VERSION = version->new('4.05'); use Carp qw/cluck :DEFAULT/; use base qw/ App::ClusterSSH::Base /; use App::ClusterSSH::Host; use App::ClusterSSH::Config; use App::ClusterSSH::Helper; use App::ClusterSSH::Cluster; use App::ClusterSSH::Getopt; use FindBin qw($Script); use POSIX ":sys_wait_h"; use POSIX qw/:sys_wait_h strftime mkfifo/; use File::Temp qw/:POSIX/; use Fcntl; use Tk 800.022; use Tk::Xlib; use Tk::ROText; require Tk::Dialog; require Tk::LabEntry; use X11::Protocol; use X11::Protocol::Constants qw/ Shift Mod5 ShiftMask /; use vars qw/ %keysymtocode %keycodetosym /; use X11::Keysyms '%keysymtocode', 'MISCELLANY', 'XKB_KEYS', '3270', 'LATIN1', 'LATIN2', 'LATIN3', 'LATIN4', 'KATAKANA', 'ARABIC', 'CYRILLIC', 'GREEK', 'TECHNICAL', 'SPECIAL', 'PUBLISHING', 'APL', 'HEBREW', 'THAI', 'KOREAN'; use File::Basename; use Module::Load; use Net::hostent; use Sys::Hostname; use English; use Socket; use File::Path qw(make_path); # Notes on general order of processing # # parse cmd line options for extra config files # load system configuration files # load cfg files from options # overlay rest of cmd line args onto options # record all clusters # parse given tags/hostnames and resolve to connections # open terminals # optionally open console if required sub new { my ( $class, %args ) = @_; my $self = $class->SUPER::new(%args); $self->{cluster} = App::ClusterSSH::Cluster->new( parent => $self, ); $self->{options} = App::ClusterSSH::Getopt->new( parent => $self, ); $self->{config} = App::ClusterSSH::Config->new( parent => $self, ); $self->{helper} = App::ClusterSSH::Helper->new( parent => $self, ); # catch and reap any zombies $SIG{CHLD} = sub { my $kid; do { $kid = waitpid( -1, WNOHANG ); $self->debug( 2, "REAPER currently returns: $kid" ); } until ( $kid == -1 || $kid == 0 ); }; return $self; } sub config { my ($self) = @_; return $self->{config}; } sub cluster { my ($self) = @_; return $self->{cluster}; } sub helper { my ($self) = @_; return $self->{helper}; } sub options { my ($self) = @_; return $self->{options}; } sub getopts { my ($self) = @_; return $self->options->getopts; } sub add_option { my ( $self, %args ) = @_; return $self->{options}->add_option(%args); } my %windows; # hash for all window definitions my %menus; # hash for all menu definitions my @servers; # array of servers provided on cmdline my %servers; # hash of server cx info my $xdisplay; my %keyboardmap; my $sysconfigdir = "/etc"; my %ssh_hostnames; my $host_menu_static_items; # number of items in the host menu that should # not be touched by build_host_menu my (@dead_hosts); # list of hosts whose sessions are now closed my $sort = sub { sort @_ }; # reference to our sort function which may later # be changed in run() if the user has asked for # natural sorting $keysymtocode{unknown_sym} = 0xFFFFFF; # put in a default "unknown" entry $keysymtocode{EuroSign} = 0x20AC; # Euro sign - missing from X11::Protocol::Keysyms # and also map it the other way %keycodetosym = reverse %keysymtocode; # Set up UTF-8 on STDOUT binmode STDOUT, ":utf8"; #use bytes; ### all sub-routines ### # Pick a color based on a string. sub pick_color { my ($string) = @_; my @components = qw(AA BB CC EE); my $color = 0; for ( my $i = 0; $i < length($string); $i++ ) { $color += ord( substr( $string, $i, 1 ) ); } srand($color); my $ans = '\\#'; $ans .= $components[ int( 4 * rand() ) ]; $ans .= $components[ int( 4 * rand() ) ]; $ans .= $components[ int( 4 * rand() ) ]; return $ans; } # close a specific host session sub terminate_host($) { my ( $self, $svr ) = @_; $self->debug( 2, "Killing session for $svr" ); if ( !$servers{$svr} ) { $self->debug( 2, "Session for $svr not found" ); return; } $self->debug( 2, "Killing process $servers{$svr}{pid}" ); kill( 9, $servers{$svr}{pid} ) if kill( 0, $servers{$svr}{pid} ); delete( $servers{$svr} ); return $self; } # catch_all exit routine that should always be used sub exit_prog() { my ($self) = @_; $self->debug( 3, "Exiting via normal routine" ); # for each of the client windows, send a kill. # to make sure we catch all children, even when they haven't # finished starting or received the kill signal, do it like this while (%servers) { foreach my $svr ( keys(%servers) ) { $self->terminate_host($svr); } } exit 0; } sub evaluate_commands { my ($self) = @_; my ( $return, $user, $port, $host ); # break apart the given host string to check for user or port configs my $evaluate = $self->options->evaluate; print "{evaluate}=", $evaluate, "\n"; $user = $1 if ( ${evaluate} =~ s/^(.*)@// ); $port = $1 if ( ${evaluate} =~ s/:(\w+)$// ); $host = ${evaluate}; $user = $user ? "-l $user" : ""; if ( $self->config->{comms} eq "telnet" ) { $port = $port ? " $port" : ""; } else { $port = $port ? "-p $port" : ""; } print STDERR "Testing terminal - running command:\n"; my $command = "$^X -e 'print \"Base terminal test\n\"; sleep 2'"; my $terminal_command = join( ' ', $self->config->{terminal}, $self->config->{terminal_allow_send_events}, "-e " ); my $run_command = "$terminal_command $command"; print STDERR $run_command, $/; system($run_command); print STDERR "\nTesting comms - running command:\n"; my $comms_command = join( ' ', $self->config->{ $self->config->{comms} }, $self->config->{ $self->config->{comms} . "_args" } ); if ( $self->config->{comms} eq "telnet" ) { $comms_command .= " $host $port"; } else { $comms_command .= " $user $port $host hostname ; echo Got hostname via ssh; sleep 2"; } print STDERR $comms_command, $/; system($comms_command); $run_command = "$terminal_command '$comms_command'"; print STDERR $run_command, $/; system($run_command); $self->exit_prog; } sub load_keyboard_map() { my ($self) = @_; # load up the keyboard map to convert keysyms to keyboardmap my $min = $xdisplay->{min_keycode}; my $count = $xdisplay->{max_keycode} - $min; my @keyboard = $xdisplay->GetKeyboardMapping( $min, $count ); # @keyboard arry # 0 = plain key # 1 = with shift # 2 = with Alt-GR # 3 = with shift + AltGr # 4 = same as 2 - control/alt? # 5 = same as 3 - shift-control-alt? $self->debug( 1, "Loading keymaps and keycodes" ); my %keyboard_modifier_priority = ( 'sa' => 3, # lowest 'a' => 2, 's' => 1, 'n' => 0, # highest ); my %keyboard_stringlike_modifiers = reverse %keyboard_modifier_priority; # try to associate $keyboard=X11->GetKeyboardMapping table with X11::Keysyms foreach my $i ( 0 .. $#keyboard ) { for my $modifier ( 0 .. 3 ) { if ( defined( $keyboard[$i][$modifier] ) && defined( $keycodetosym{ $keyboard[$i][$modifier] } ) ) { # keyboard layout contains the keycode at $modifier level if (defined( $keyboardmap{ $keycodetosym{ $keyboard[$i][$modifier] } } ) ) { # we already have a mapping, let's see whether current one is better (lower shift state) my ( $mod_code, $key_code ) = $keyboardmap{ $keycodetosym{ $keyboard[$i] [$modifier] } } =~ /^(\D+)(\d+)$/; # it is not easy to get around our own alien logic storing modifiers ;-) if ( $modifier < $keyboard_modifier_priority{$mod_code} ) { # YES! current keycode have priority over old one (phew!) $keyboardmap{ $keycodetosym{ $keyboard[$i][$modifier] } } = $keyboard_stringlike_modifiers{$modifier} . ( $i + $min ); } } else { # we don't yet have a mapping... piece of cake! $keyboardmap{ $keycodetosym{ $keyboard[$i][$modifier] } } = $keyboard_stringlike_modifiers{$modifier} . ( $i + $min ); } } else { # we didn't get the code from X11::Keysyms if ( defined( $keyboard[$i][$modifier] ) && $keyboard[$i][$modifier] != 0 ) { # ignore code=0 $self->debug( 2, "Unknown keycode ", $keyboard[$i][$modifier] ); } } } } # don't know these two key combs yet... #$keyboardmap{ $keycodetosym { $keyboard[$_][4] } } = $_ + $min; #$keyboardmap{ $keycodetosym { $keyboard[$_][5] } } = $_ + $min; #print "$_ => $keyboardmap{$_}\n" foreach(sort(keys(%keyboardmap))); #print "keysymtocode: $keysymtocode{o}\n"; #die; } sub get_keycode_state($) { my ( $self, $keysym ) = @_; $keyboardmap{$keysym} =~ m/^(\D+)(\d+)$/; my ( $state, $code ) = ( $1, $2 ); $self->debug( 2, "keyboardmap=:", $keyboardmap{$keysym}, ":" ); $self->debug( 2, "state=$state, code=$code" ); SWITCH: for ($state) { /^n$/ && do { $state = 0; last SWITCH; }; /^s$/ && do { $state = Shift(); last SWITCH; }; /^a$/ && do { $state = Mod5(); last SWITCH; }; /^sa$/ && do { $state = Shift() + Mod5(); last SWITCH; }; die("Should never reach here"); } $self->debug( 2, "returning state=:$state: code=:$code:" ); return ( $state, $code ); } sub resolve_names(@) { my ( $self, @servers ) = @_; $self->debug( 2, 'Resolving cluster names: started' ); foreach (@servers) { my $dirty = $_; my $username = q{}; $self->debug( 3, 'Checking tag ', $_ ); if ( $dirty =~ s/^(.*)@// ) { $username = $1; } my @tag_list = $self->cluster->get_tag($dirty); if ( $self->config->{use_all_a_records} && $dirty !~ m/^(\d{1,3}\.?){4}$/ && !@tag_list ) { my $hostobj = gethostbyname($dirty); if ( defined($hostobj) ) { my @alladdrs = map { inet_ntoa($_) } @{ $hostobj->addr_list }; $self->cluster->register_tag( $dirty, @alladdrs ); if ( $#alladdrs > 0 ) { $self->debug( 3, 'Expanded to ', join( ' ', $self->cluster->get_tag($dirty) ) ); @tag_list = $self->cluster->get_tag($dirty); } else { # don't expand if there is only one record found $self->debug( 3, 'Only one A record' ); } } } if (@tag_list) { $self->debug( 3, '... it is a cluster' ); foreach my $node (@tag_list) { if ($username) { $node =~ s/^(.*)@//; $node = $username . '@' . $node; } push( @servers, $node ); } $_ = q{}; } } # now run everything through the external command, if one is defined if ( $self->config->{external_cluster_command} ) { $self->debug( 4, 'External cluster command defined' ); # use a second array here in case of failure so previously worked # out entries are not lost my @new_servers; eval { @new_servers = $self->cluster->get_external_clusters(@servers); }; if ($@) { warn $@, $/; } else { @servers = @new_servers; } } # now clean the array up @servers = grep { $_ !~ m/^$/ } @servers; if ( $self->config->{unique_servers} ) { $self->debug( 3, 'removing duplicate server names' ); @servers = remove_repeated_servers(@servers); } $self->debug( 3, 'leaving with ', $_ ) foreach (@servers); $self->debug( 2, 'Resolving cluster names: completed' ); return (@servers); } sub remove_repeated_servers { my %all = (); @all{@_} = 1; return ( keys %all ); } sub change_main_window_title() { my ($self) = @_; my $number = keys(%servers); $windows{main_window}->title( $self->config->{title} . " [$number]" ); } sub show_history() { my ($self) = @_; if ( $self->config->{show_history} ) { $windows{history}->packForget(); $windows{history}->selectAll(); $windows{history}->deleteSelected(); $self->config->{show_history} = 0; } else { $windows{history}->pack( -fill => "x", -expand => 1, ); $self->config->{show_history} = 1; } } sub update_display_text($) { my ( $self, $char ) = @_; return if ( !$self->config->{show_history} ); $self->debug( 2, "Dropping :$char: into display" ); SWITCH: { foreach ($char) { /^Return$/ && do { $windows{history}->insert( 'end', "\n" ); last SWITCH; }; /^BackSpace$/ && do { $windows{history}->delete('end - 2 chars'); last SWITCH; }; /^(:?Shift|Control|Alt)_(:?R|L)$/ && do { last SWITCH; }; length($char) > 1 && do { $windows{history} ->insert( 'end', chr( $keysymtocode{$char} ) ) if ( $keysymtocode{$char} ); last SWITCH; }; do { $windows{history}->insert( 'end', $char ); last SWITCH; }; } } return $self; } sub substitute_macros { my ( $self, $svr, $text ) = @_; return $text unless ( $self->config->{macros_enabled} eq 'yes' ); { my $macro_servername = $self->config->{macro_servername}; ( my $servername = $svr ) =~ s/\s+//; $text =~ s!$macro_servername!$servername!xsmg; } { my $macro_hostname = $self->config->{macro_hostname}; my $hostname = $servers{$svr}{givenname}; $text =~ s!$macro_hostname!$hostname!xsmg; } { my $macro_username = $self->config->{macro_username}; my $username = $servers{$svr}{username}; $username ||= getpwuid($UID); $text =~ s!$macro_username!$username!xsmg; } { my $macro_newline = $self->config->{macro_newline}; $text =~ s!$macro_newline!\n!xsmg; } { my $macro_version = $self->config->{macro_version}; $text =~ s/$macro_version/$VERSION/xsmg; } return $text; } sub send_text($@) { my $self = shift; my $svr = shift; my $text = join( "", @_ ); $self->debug( 2, "servers{$svr}{wid}=$servers{$svr}{wid}" ); $self->debug( 3, "Sending to '$svr' text:$text:" ); $text = $self->substitute_macros( $svr, $text ); foreach my $char ( split( //, $text ) ) { next if ( !defined($char) ); my $ord = ord($char); $ord = 65293 if ( $ord == 10 ); # convert 'Return' to sym if ( !defined( $keycodetosym{$ord} ) ) { warn("Unknown character in xmodmap keytable: $char ($ord)\n"); next; } my $keysym = $keycodetosym{$ord}; my $keycode = $keysymtocode{$keysym}; $self->debug( 2, "Looking for char :$char: with ord :$ord:" ); $self->debug( 2, "Looking for keycode :$keycode:" ); $self->debug( 2, "Looking for keysym :$keysym:" ); $self->debug( 2, "Looking for keyboardmap :", $keyboardmap{$keysym}, ":" ); my ( $state, $code ) = $self->get_keycode_state($keysym); $self->debug( 2, "Got state :$state: code :$code:" ); for my $event (qw/KeyPress KeyRelease/) { $self->debug( 2, "sending event=$event code=:$code: state=:$state:" ); $xdisplay->SendEvent( $servers{$svr}{wid}, 0, $xdisplay->pack_event_mask($event), $xdisplay->pack_event( 'name' => $event, 'detail' => $code, 'state' => $state, 'event' => $servers{$svr}{wid}, 'root' => $xdisplay->root(), 'same_screen' => 1, ), ); } } $xdisplay->flush(); } sub send_text_to_all_servers { my $self = shift; my $text = join( '', @_ ); foreach my $svr ( keys(%servers) ) { $self->send_text( $svr, $text ) if ( $servers{$svr}{active} == 1 ); } } sub send_variable_text_to_all_servers($&) { my ( $self, $code ) = @_; foreach my $svr ( keys(%servers) ) { $self->send_text( $svr, $code->($svr) ) if ( $servers{$svr}{active} == 1 ); } } sub send_resizemove($$$$$) { my ( $self, $win, $x_pos, $y_pos, $x_siz, $y_siz ) = @_; $self->debug( 3, "Moving window $win to x:$x_pos y:$y_pos (size x:$x_siz y:$y_siz)" ); #$self->debug( 2, "resize move normal: ", $xdisplay->atom('WM_NORMAL_HINTS') ); #$self->debug( 2, "resize move size: ", $xdisplay->atom('WM_SIZE_HINTS') ); # set the window to have "user" set size & position, rather than "program" $xdisplay->req( 'ChangeProperty', $win, $xdisplay->atom('WM_NORMAL_HINTS'), $xdisplay->atom('WM_SIZE_HINTS'), 32, 'Replace', # create data struct on-the-fly to set bitwise flags pack( 'LLLLL' . 'x[L]' x 12, 1 | 2, $x_pos, $y_pos, $x_siz, $y_siz ), ); $xdisplay->req( 'ConfigureWindow', $win, 'x' => $x_pos, 'y' => $y_pos, 'width' => $x_siz, 'height' => $y_siz, ); #$xdisplay->flush(); # dont flush here, but after all tiling worked out } sub open_client_windows(@) { my $self = shift; foreach (@_) { next unless ($_); my $server_object = App::ClusterSSH::Host->parse_host_string($_); my $username = $server_object->get_username(); $username = $self->config->{user} if ( !$username && $self->config->{user} ); my $port = $server_object->get_port(); $port = $self->config->{port} if ( $self->config->{port} ); my $server = $server_object->get_hostname(); my $master = $server_object->get_master(); my $given_server_name = $server_object->get_hostname(); # see if we can find the hostname - if not, drop it my $realname = $server_object->get_realname(); if ( !$realname ) { my $text = "WARNING: '$_' unknown"; if (%ssh_hostnames) { $text .= " (unable to resolve and not in user ssh config file)"; } warn( $text, $/ ); #next; # Debian bug 499935 - ignore warnings about hostname resolution } $self->debug( 3, "username=$username, server=$server, port=$port" ); my $color = ''; if ( $self->config->{terminal_colorize} ) { my $c = pick_color($server); if ( $self->config->{terminal_bg_style} eq 'dark' ) { $color = "-bg \\#000000 -fg $c"; } else { $color = "-fg \\#000000 -bg $c"; } } my $count = q{}; while ( defined( $servers{ $server . q{ } . $count } ) ) { $count++; } $server .= q{ } . $count; $servers{$server}{connect_string} = $_; $servers{$server}{givenname} = $given_server_name; $servers{$server}{realname} = $realname; $servers{$server}{username} = $self->config->{user}; $servers{$server}{username} = $username if ($username); $servers{$server}{username} = $username || ''; $servers{$server}{port} = $port || ''; $servers{$server}{master} = $self->config->{mstr} || ''; $servers{$server}{master} = $master if ($master); $self->debug( 2, "Working on server $server for $_" ); $servers{$server}{pipenm} = tmpnam(); $self->debug( 2, "Set temp name to: $servers{$server}{pipenm}" ); mkfifo( $servers{$server}{pipenm}, 0600 ) or die("Cannot create pipe: $!"); # NOTE: the PID is re-fetched from the xterm window (via helper_script) # later as it changes and we need an accurate PID as it is widely used $servers{$server}{pid} = fork(); if ( !defined( $servers{$server}{pid} ) ) { die("Could not fork: $!"); } if ( $servers{$server}{pid} == 0 ) { # this is the child # Since this is the child, we can mark any server unresolved without # affecting the main program $servers{$server}{realname} .= "==" if ( !$realname ); # copy and amend the config provided to the helper script my $local_config = $self->config; $local_config->{command} = $self->substitute_macros( $server, $local_config->{command} ); my $exec = join( ' ', $self->config->{terminal}, $color, $self->config->{terminal_args}, $self->config->{terminal_allow_send_events}, $self->config->{terminal_title_opt}, "'" . $self->config->{title} . ': ' . $servers{$server}{connect_string} . "'", '-font ' . $self->config->{terminal_font}, "-e " . $^X . ' -e ', "'" . $self->helper->script( $self->config ) . "'", " " . $servers{$server}{pipenm}, " " . $servers{$server}{givenname}, " '" . $servers{$server}{username} . "'", " '" . $servers{$server}{port} . "'", " '" . $servers{$server}{master} . "'", ); $self->debug( 2, "Terminal exec line:\n$exec\n" ); exec($exec) == 0 or warn("Failed: $!"); } } # Now all the windows are open, get all their window IDs foreach my $server ( keys(%servers) ) { next if ( defined( $servers{$server}{active} ) ); # sleep for a moment to give system time to come up select( undef, undef, undef, 0.1 ); # block on open so we get the text when it comes in unless ( sysopen( $servers{$server}{pipehl}, $servers{$server}{pipenm}, O_RDONLY ) ) { warn( "Cannot open pipe for reading when talking to $server: $!\n"); } else { # NOTE: read both the xterm pid and the window ID here # get PID here as it changes from the fork above, and we need the # correct PID $self->debug( 2, "Performing sysread" ); my $piperead; sysread( $servers{$server}{pipehl}, $piperead, 100 ); ( $servers{$server}{pid}, $servers{$server}{wid} ) = split( /:/, $piperead, 2 ); warn("Cannot determ pid of '$server' window\n") unless $servers{$server}{pid}; warn("Cannot determ window ID of '$server' window\n") unless $servers{$server}{wid}; $self->debug( 2, "Done and closing pipe" ); close( $servers{$server}{pipehl} ); } delete( $servers{$server}{pipehl} ); unlink( $servers{$server}{pipenm} ); delete( $servers{$server}{pipenm} ); $servers{$server}{active} = 1; # mark as active $self->config->{internal_activate_autoquit} = 1; # activate auto_quit if in use } $self->debug( 2, "All client windows opened" ); $self->config->{internal_total} = int( keys(%servers) ); return $self; } sub get_font_size() { my ($self) = @_; $self->debug( 2, "Fetching font size" ); # get atom name<->number relations my $quad_width = $xdisplay->atom("QUAD_WIDTH"); my $pixel_size = $xdisplay->atom("PIXEL_SIZE"); my $font = $xdisplay->new_rsrc; my $terminal_font = $self->config->{terminal_font}; $xdisplay->OpenFont( $font, $terminal_font ); my %font_info; eval { (%font_info) = $xdisplay->QueryFont($font); } || die( "Fatal: Unrecognised font used ($terminal_font).\n" . "Please amend \$HOME/.clusterssh/config with a valid font (see man page).\n" ); $self->config->{internal_font_width} = $font_info{properties}{$quad_width}; $self->config->{internal_font_height} = $font_info{properties}{$pixel_size}; if ( !$self->config->{internal_font_width} || !$self->config->{internal_font_height} ) { die( "Fatal: Unrecognised font used ($terminal_font).\n" . "Please amend \$HOME/.clusterssh/config with a valid font (see man page).\n" ); } $self->debug( 2, "Done with font size" ); return $self; } sub show_console() { my ($self) = shift; $self->debug( 2, "Sending console to front" ); $self->config->{internal_previous_state} = "mid-change"; # fudge the counter to drop a redraw event; $self->config->{internal_map_count} -= 4; $xdisplay->flush(); $windows{main_window}->update(); select( undef, undef, undef, 0.2 ); #sleep for a mo $windows{main_window}->withdraw; # Sleep for a moment to give WM time to bring console back select( undef, undef, undef, 0.5 ); if ( $self->config->{menu_send_autotearoff} ) { $menus{send}->menu->tearOffMenu()->raise; } if ( $self->config->{menu_host_autotearoff} ) { $menus{hosts}->menu->tearOffMenu()->raise; } $windows{main_window}->deiconify; $windows{main_window}->raise; $windows{main_window}->focus( -force ); $windows{text_entry}->focus( -force ); $self->config->{internal_previous_state} = "normal"; # fvwm seems to need this (Debian #329440) $windows{main_window}->MapWindow; return $self; } # leave function def open here so we can be flexible in how it's called sub retile_hosts { my ( $self, $force ) = @_; $force ||= ""; $self->debug( 2, "Retiling windows" ); my %config; if ( $self->config->{window_tiling} ne "yes" && !$force ) { $self->debug( 3, "Not meant to be tiling; just reshow windows as they were" ); foreach my $server ( reverse( keys(%servers) ) ) { $xdisplay->req( 'MapWindow', $servers{$server}{wid} ); } $xdisplay->flush(); $self->show_console(); return; } # ALL SIZES SHOULD BE IN PIXELS for consistency $self->debug( 2, "Count is currently ", $self->config->{internal_total} ); if ( $self->config->{internal_total} == 0 ) { # If nothing to tile, don't bother doing anything, just show console return $self->show_console(); } # work out terminal pixel size from terminal size & font size # does not include any title bars or scroll bars - purely text area $self->config->{internal_terminal_cols} = ( $self->config->{terminal_size} =~ /(\d+)x.*/ )[0]; $self->config->{internal_terminal_width} = ( $self->config->{internal_terminal_cols} * $self->config->{internal_font_width} ) + $self->config->{terminal_decoration_width}; $self->config->{internal_terminal_rows} = ( $self->config->{terminal_size} =~ /.*x(\d+)/ )[0]; $self->config->{internal_terminal_height} = ( $self->config->{internal_terminal_rows} * $self->config->{internal_font_height} ) + $self->config->{terminal_decoration_height}; # fetch screen size $self->config->{internal_screen_height} = $xdisplay->{height_in_pixels}; $self->config->{internal_screen_width} = $xdisplay->{width_in_pixels}; # Now, work out how many columns of terminals we can fit on screen $self->config->{internal_columns} = int( ( $self->config->{internal_screen_width} - $self->config->{screen_reserve_left} - $self->config->{screen_reserve_right} ) / ( $self->config->{internal_terminal_width} + $self->config->{terminal_reserve_left} + $self->config->{terminal_reserve_right} ) ); # Work out the number of rows we need to use to fit everything on screen $self->config->{internal_rows} = int( ( $self->config->{internal_total} / $self->config->{internal_columns} ) + 0.999 ); $self->debug( 2, "Screen Columns: ", $self->config->{internal_columns} ); $self->debug( 2, "Screen Rows: ", $self->config->{internal_rows} ); # Now adjust the height of the terminal to either the max given, # or to get everything on screen { my $height = int( ( ( $self->config->{internal_screen_height} - $self->config->{screen_reserve_top} - $self->config->{screen_reserve_bottom} ) - ( $self->config->{internal_rows} * ( $self->config->{terminal_reserve_top} + $self->config->{terminal_reserve_bottom} ) ) ) / $self->config->{internal_rows} ); $self->debug( 2, "Terminal height=$height" ); $self->config->{internal_terminal_height} = ( $height > $self->config->{internal_terminal_height} ? $self->config->{internal_terminal_height} : $height ); } $self->config->dump("noexit") if ( $self->options->debug > 1 ); # now we have the info, plot first window position my @hosts; my ( $current_x, $current_y, $current_row, $current_col ) = 0; if ( $self->config->{window_tiling_direction} =~ /right/i ) { $self->debug( 2, "Tiling top left going bot right" ); @hosts = $sort->( keys(%servers) ); $current_x = $self->config->{screen_reserve_left} + $self->config->{terminal_reserve_left}; $current_y = $self->config->{screen_reserve_top} + $self->config->{terminal_reserve_top}; $current_row = 0; $current_col = 0; } else { $self->debug( 2, "Tiling bot right going top left" ); @hosts = reverse( $sort->( keys(%servers) ) ); $current_x = $self->config->{screen_reserve_right} - $self->config->{internal_screen_width} - $self->config->{terminal_reserve_right} - $self->config->{internal_terminal_width}; $current_y = $self->config->{screen_reserve_bottom} - $self->config->{internal_screen_height} - $self->config->{terminal_reserve_bottom} - $self->config->{internal_terminal_height}; $current_row = $self->config->{internal_rows} - 1; $current_col = $self->config->{internal_columns} - 1; } # Unmap windows (hide them) # Move windows to new locatation # Remap all windows in correct order foreach my $server (@hosts) { $self->debug( 3, "x:$current_x y:$current_y, r:$current_row c:$current_col" ); # sf tracker 3061999 # $xdisplay->req( 'UnmapWindow', $servers{$server}{wid} ); if ( $self->config->{unmap_on_redraw} =~ /yes/i ) { $xdisplay->req( 'UnmapWindow', $servers{$server}{wid} ); } $self->debug( 2, "Moving $server window" ); $self->send_resizemove( $servers{$server}{wid}, $current_x, $current_y, $self->config->{internal_terminal_width}, $self->config->{internal_terminal_height} ); $xdisplay->flush(); select( undef, undef, undef, 0.1 ); # sleep for a moment for the WM if ( $self->config->{window_tiling_direction} =~ /right/i ) { # starting top left, and move right and down $current_x += $self->config->{terminal_reserve_left} + $self->config->{terminal_reserve_right} + $self->config->{internal_terminal_width}; $current_col += 1; if ( $current_col == $self->config->{internal_columns} ) { $current_y += $self->config->{terminal_reserve_top} + $self->config->{terminal_reserve_bottom} + $self->config->{internal_terminal_height}; $current_x = $self->config->{screen_reserve_left} + $self->config->{terminal_reserve_left}; $current_row++; $current_col = 0; } } else { # starting bottom right, and move left and up $current_col -= 1; if ( $current_col < 0 ) { $current_row--; $current_col = $self->config->{internal_columns}; } } } # Now remap in right order to get overlaps correct if ( $self->config->{window_tiling_direction} =~ /right/i ) { foreach my $server ( reverse(@hosts) ) { $self->debug( 2, "Setting focus on $server" ); $xdisplay->req( 'MapWindow', $servers{$server}{wid} ); # flush every time and wait a moment (The WMs are so slow...) $xdisplay->flush(); select( undef, undef, undef, 0.1 ); # sleep for a mo } } else { foreach my $server (@hosts) { $self->debug( 2, "Setting focus on $server" ); $xdisplay->req( 'MapWindow', $servers{$server}{wid} ); # flush every time and wait a moment (The WMs are so slow...) $xdisplay->flush(); select( undef, undef, undef, 0.1 ); # sleep for a mo } } # and as a last item, set focus back onto the console return $self->show_console(); } sub capture_terminal() { my ($self) = @_; $self->debug( 0, "Stub for capturing a terminal window" ); return if ( $self->coptions->debug < 6 ); # should never see this - all experimental anyhow foreach my $server ( keys(%servers) ) { foreach my $data ( keys( %{ $servers{$server} } ) ) { print "server $server key $data is $servers{$server}{$data}\n"; } } #return; my %atoms; for my $atom ( $xdisplay->req( 'ListProperties', $servers{loki}{wid} ) ) { $atoms{ $xdisplay->atom_name($atom) } = $xdisplay->req( 'GetProperty', $servers{loki}{wid}, $atom, "AnyPropertyType", 0, 200, 0 ); print $xdisplay->atom_name($atom), " ($atom) => "; print "join here\n"; print join( "\n", $xdisplay->req( 'GetProperty', $servers{loki}{wid}, $atom, "AnyPropertyType", 0, 200, 0 ) ), "\n"; } print "list by number\n"; for my $atom ( 1 .. 90 ) { print "$atom: ", $xdisplay->req( 'GetAtomName', $atom ), "\n"; print join( "\n", $xdisplay->req( 'GetProperty', $servers{loki}{wid}, $atom, "AnyPropertyType", 0, 200, 0 ) ), "\n"; } print "\n"; print "size hints\n"; print join( "\n", $xdisplay->req( 'GetProperty', $servers{loki}{wid}, 42, "AnyPropertyType", 0, 200, 0 ) ), "\n"; print "atom list by name\n"; foreach ( keys(%atoms) ) { print "atom :$_: = $atoms{$_}\n"; } print "geom\n"; print join " ", $xdisplay->req( 'GetGeometry', $servers{loki}{wid} ), $/; print "attrib\n"; print join " ", $xdisplay->req( 'GetWindowAttributes', $servers{loki}{wid} ), $/; } sub toggle_active_state() { my ($self) = @_; $self->debug( 2, "Toggling active state of all hosts" ); foreach my $svr ( sort( keys(%servers) ) ) { $servers{$svr}{active} = not $servers{$svr}{active}; } } sub set_all_active() { my ($self) = @_; $self->debug( 2, "Setting all hosts to be active" ); foreach my $svr ( keys(%servers) ) { $servers{$svr}{active} = 1; } } sub set_half_inactive() { my ($self) = @_; $self->debug( 2, "Setting approx half of all hosts to inactive" ); my (@keys) = keys(%servers); $#keys /= 2; foreach my $svr (@keys) { $servers{$svr}{active} = 0; } } sub close_inactive_sessions() { my ($self) = @_; $self->debug( 2, "Closing all inactive sessions" ); foreach my $svr ( sort( keys(%servers) ) ) { $self->terminate_host($svr) if ( !$servers{$svr}{active} ); } $self->build_hosts_menu(); } sub add_host_by_name() { my ($self) = @_; $self->debug( 2, "Adding host to menu here" ); $windows{host_entry}->focus(); my $answer = $windows{addhost}->Show(); if ( !$answer || $answer ne "Add" ) { $menus{host_entry} = ""; return; } if ( $menus{host_entry} ) { $self->debug( 2, "host=", $menus{host_entry} ); my @names = $self->resolve_names( split( /\s+/, $menus{host_entry} ) ); $self->debug( 0, 'Opening to: ', join( ' ', @names ) ) if (@names); $self->open_client_windows(@names); } if ( defined $menus{listbox} && $menus{listbox}->curselection() ) { my @hosts = $menus{listbox}->get( $menus{listbox}->curselection() ); $self->debug( 2, "host=", join( ' ', @hosts ) ); $self->open_client_windows( $self->resolve_names(@hosts) ); } $self->build_hosts_menu(); $menus{host_entry} = ""; # retile, or bring console to front if ( $self->config->{window_tiling} eq "yes" ) { return $self->retile_hosts(); } else { return $self->show_console(); } } # attempt to re-add any hosts that have been closed since we started # the session - either through errors or deliberate log-outs sub re_add_closed_sessions() { my ($self) = @_; $self->debug( 2, "add closed sessions" ); return if ( scalar(@dead_hosts) == 0 ); my @new_hosts = @dead_hosts; # clear out the list in case open fails @dead_hosts = qw//; # try to open $self->open_client_windows(@new_hosts); # update hosts list with current state $self->build_hosts_menu(); # retile, or bring console to front if ( $self->config->{window_tiling} eq "yes" ) { return $self->retile_hosts(); } else { return $self->show_console(); } } sub build_hosts_menu() { my ($self) = @_; $self->debug( 2, "Building hosts menu" ); # first, empty the hosts menu from the last static entry + 1 on my $menu = $menus{bar}->entrycget( 'Hosts', -menu ); $menu->delete( $host_menu_static_items, 'end' ); $self->debug( 3, "Menu deleted" ); # add back the separator $menus{hosts}->separator; $self->debug( 3, "Parsing list" ); my $menu_item_counter = $host_menu_static_items; foreach my $svr ( $sort->( keys(%servers) ) ) { $self->debug( 3, "Checking $svr and restoring active value" ); my $colbreak = 0; if ( $menu_item_counter > $self->config->{max_host_menu_items} ) { $colbreak = 1; $menu_item_counter = 1; } $menus{hosts}->checkbutton( -label => $svr, -variable => \$servers{$svr}{active}, -columnbreak => $colbreak, ); $menu_item_counter++; } $self->debug( 3, "Changing window title" ); $self->change_main_window_title(); $self->debug( 2, "Done" ); } sub setup_repeat() { my ($self) = @_; $self->config->{internal_count} = 0; # if this is too fast then we end up with queued invocations # with no time to run anything else $windows{main_window}->repeat( 500, sub { $self->config->{internal_count} = 0 if ( $self->config->{internal_count} > 60000 ) ; # reset if too high $self->config->{internal_count}++; my $build_menu = 0; $self->debug( 5, "Running repeat;count=", $self->config->{internal_count} ); #$self->debug( 3, "Number of servers in hash is: ", scalar( keys(%servers) ) ); foreach my $svr ( keys(%servers) ) { if ( defined( $servers{$svr}{pid} ) ) { if ( !kill( 0, $servers{$svr}{pid} ) ) { $build_menu = 1; push( @dead_hosts, $servers{$svr}{givenname} ); delete( $servers{$svr} ); $self->debug( 0, "$svr session closed" ); } } else { warn("Lost pid of $svr; deleting\n"); delete( $servers{$svr} ); } } # get current number of clients $self->config->{internal_total} = int( keys(%servers) ); #$self->debug( 3, "Number after tidy is: ", $config{internal_total} ); # get current number of clients $self->config->{internal_total} = int( keys(%servers) ); #$self->debug( 3, "Number after tidy is: ", $config{internal_total} ); # If there are no hosts in the list and we are set to autoquit if ( $self->config->{internal_total} == 0 && $self->config->{auto_quit} =~ /yes/i ) { # and some clients were actually opened... if ( $self->config->{internal_activate_autoquit} ) { $self->debug( 2, "Autoquitting" ); $self->exit_prog; } } # rebuild host menu if something has changed $self->build_hosts_menu() if ($build_menu); # clean out text area, anyhow $menus{entrytext} = ""; #$self->debug( 3, "repeat completed" ); } ); $self->debug( 2, "Repeat setup" ); return $self; } ### Window and menu definitions ### sub create_windows() { my ($self) = @_; $self->debug( 2, "create_windows: started" ); $windows{main_window} = MainWindow->new( -title => "ClusterSSH", -class => 'cssh', ); $windows{main_window}->withdraw; # leave withdrawn until needed if ( defined( $self->config->{console_position} ) && $self->config->{console_position} =~ /[+-]\d+[+-]\d+/ ) { $windows{main_window}->geometry( $self->config->{console_position} ); } $menus{entrytext} = ""; $windows{text_entry} = $windows{main_window}->Entry( -textvariable => \$menus{entrytext}, -insertborderwidth => 4, -width => 25, -class => 'cssh', )->pack( -fill => "x", -expand => 1, ); $windows{history} = $windows{main_window}->Scrolled( "ROText", -insertborderwidth => 4, -width => $self->config->{history_width}, -height => $self->config->{history_height}, -state => 'normal', -takefocus => 0, -class => 'cssh', ); $windows{history}->bindtags(undef); if ( $self->config->{show_history} ) { $windows{history}->pack( -fill => "x", -expand => 1, ); } $windows{main_window}->bind( '<Destroy>' => sub { $self->exit_prog } ); # remove all Paste events so we set them up cleanly $windows{main_window}->eventDelete('<<Paste>>'); # Set up paste events from scratch if ( $self->config->{key_paste} && $self->config->{key_paste} ne "null" ) { $windows{main_window}->eventAdd( '<<Paste>>' => '<' . $self->config->{key_paste} . '>' ); } if ( $self->config->{mouse_paste} && $self->config->{mouse_paste} ne "null" ) { $windows{main_window}->eventAdd( '<<Paste>>' => '<' . $self->config->{mouse_paste} . '>' ); } $windows{main_window}->bind( '<<Paste>>' => sub { $self->debug( 2, "PASTE EVENT" ); $menus{entrytext} = ""; my $paste_text = ''; # SelectionGet is fatal if no selection is given Tk::catch { $paste_text = $windows{main_window}->SelectionGet; }; if ( !length($paste_text) ) { warn("Got empty paste event\n"); return; } $self->debug( 2, "Got text :", $paste_text, ":" ); $self->update_display_text($paste_text); # now sent it on foreach my $svr ( keys(%servers) ) { $self->send_text( $svr, $paste_text ) if ( $servers{$svr}{active} == 1 ); } } ); $windows{help} = $windows{main_window}->Dialog( -popover => $windows{main_window}, -overanchor => "c", -popanchor => "c", -class => 'cssh', -font => [ -family => "interface system", -size => 10, ], -text => "Cluster Administrator Console using SSH\n\nVersion: $VERSION.\n\n" . "Bug/Suggestions to http://clusterssh.sf.net/", ); $windows{manpage} = $windows{main_window}->DialogBox( -popanchor => "c", -overanchor => "c", -title => "Cssh Documentation", -buttons => ['Close'], -class => 'cssh', ); my $manpage = `pod2text -l -q=\"\" $0 2>/dev/null`; if ( !$manpage ) { $manpage = "Help is missing.\nSee that command 'pod2text' is installed and in PATH."; } $windows{mantext} = $windows{manpage}->Scrolled( "Text", )->pack( -fill => 'both' ); $windows{mantext}->insert( 'end', $manpage ); $windows{mantext}->configure( -state => 'disabled' ); $windows{addhost} = $windows{main_window}->DialogBox( -popover => $windows{main_window}, -popanchor => 'n', -title => "Add Host(s) or Cluster(s)", -buttons => [ 'Add', 'Cancel' ], -default_button => 'Add', -class => 'cssh', ); my @tags = $self->cluster->list_tags(); my @external_tags = map {"$_ *"} $self->cluster->list_external_clusters(); push( @tags, @external_tags ); if ( $self->config->{max_addhost_menu_cluster_items} && scalar @tags ) { if ( scalar @tags < $self->config->{max_addhost_menu_cluster_items} ) { $menus{listbox} = $windows{addhost}->Listbox( -selectmode => 'extended', -height => scalar @tags, -class => 'cssh', )->pack(); } else { $menus{listbox} = $windows{addhost}->Scrolled( 'Listbox', -scrollbars => 'e', -selectmode => 'extended', -height => $self->config->{max_addhost_menu_cluster_items}, -class => 'cssh', )->pack(); } $menus{listbox}->insert( 'end', sort @tags ); if (@external_tags) { $menus{addhost_text} = $windows{addhost}->add( 'Label', -class => 'cssh', -text => '* is external', )->pack(); #$menus{addhost_text}->insert('end','lkjh lkjj sdfl jklsj dflj '); } } $windows{host_entry} = $windows{addhost}->add( 'LabEntry', -textvariable => \$menus{host_entry}, -width => 20, -label => 'Host', -labelPack => [ -side => 'left', ], -class => 'cssh', )->pack( -side => 'left' ); $self->debug( 2, "create_windows: completed" ); return $self; } sub capture_map_events() { my ($self) = @_; # pick up on console minimise/maximise events so we can do all windows $windows{main_window}->bind( '<Map>' => sub { $self->debug( 3, "Entering MAP" ); my $state = $windows{main_window}->state(); $self->debug( 3, "state=$state previous=", $self->config->{internal_previous_state} ); $self->debug( 3, "Entering MAP" ); if ( $self->config->{internal_previous_state} eq $state ) { $self->debug( 3, "repeating the same" ); } if ( $self->config->{internal_previous_state} eq "mid-change" ) { $self->debug( 3, "dropping out as mid-change" ); return; } $self->debug( 3, "state=$state previous=", $self->config->{internal_previous_state} ); if ( $self->config->{internal_previous_state} eq "iconic" ) { $self->debug( 3, "running retile" ); $self->retile_hosts(); $self->debug( 3, "done with retile" ); } if ( $self->config->{internal_previous_state} ne $state ) { $self->debug( 3, "resetting prev_state" ); $self->config->{internal_previous_state} = $state; } } ); # $windows{main_window}->bind( # '<Unmap>' => sub { # $self->debug( 3, "Entering UNMAP" ); # # my $state = $windows{main_window}->state(); # $self->debug( 3, # "state=$state previous=$config{internal_previous_state}" ); # # if ( $config{internal_previous_state} eq $state ) { # $self->debug( 3, "repeating the same" ); # } # # if ( $config{internal_previous_state} eq "mid-change" ) { # $self->debug( 3, "dropping out as mid-change" ); # return; # } # # if ( $config{internal_previous_state} eq "normal" ) { # $self->debug( 3, "withdrawing all windows" ); # foreach my $server ( reverse( keys(%servers) ) ) { # $xdisplay->req( 'UnmapWindow', $servers{$server}{wid} ); # if ( $config{unmap_on_redraw} =~ /yes/i ) { # $xdisplay->req( 'UnmapWindow', # $servers{$server}{wid} ); # } # } # $xdisplay->flush(); # } # # if ( $config{internal_previous_state} ne $state ) { # $self->debug( 3, "resetting prev_state" ); # $config{internal_previous_state} = $state; # } # } # ); return $self; } # for all key event, event hotkeys so there is only 1 key binding sub key_event { my ($self) = @_; my $event = $Tk::event->T; my $keycode = $Tk::event->k; my $keysymdec = $Tk::event->N; my $keysym = $Tk::event->K; my $state = $Tk::event->s || 0; $menus{entrytext} = ""; $self->debug( 3, "=========" ); $self->debug( 3, "event =$event" ); $self->debug( 3, "keysym =$keysym (state=$state)" ); $self->debug( 3, "keysymdec=$keysymdec" ); $self->debug( 3, "keycode =$keycode" ); $self->debug( 3, "state =$state" ); $self->debug( 3, "codetosym=$keycodetosym{$keysymdec}" ) if ( $keycodetosym{$keysymdec} ); $self->debug( 3, "symtocode=$keysymtocode{$keysym}" ); $self->debug( 3, "keyboard =$keyboardmap{ $keysym }" ) if ( $keyboardmap{$keysym} ); #warn("debug stop point here"); if ( $self->config->{use_hotkeys} eq "yes" ) { my $combo = $Tk::event->s . $Tk::event->K; $combo =~ s/Mod\d-//; $self->debug( 3, "combo=$combo" ); foreach my $hotkey ( grep( /key_/, keys( %{ $self->config } ) ) ) { my $key = $self->config->{$hotkey}; next if ( $key eq "null" ); # ignore disabled keys $self->debug( 3, "key=:$key:" ); if ( $combo =~ /^$key$/ ) { $self->debug( 3, "matched combo" ); if ( $event eq "KeyRelease" ) { $self->debug( 2, "Received hotkey: $hotkey" ); $self->send_text_to_all_servers( $self->config->{macro_servername} ) if ( $hotkey eq "key_clientname" ); $self->send_text_to_all_servers( $self->config->{macro_hostname} ) if ( $hotkey eq "key_localname" ); $self->send_text_to_all_servers( $self->config->{macro_username} ) if ( $hotkey eq "key_username" ); $self->add_host_by_name() if ( $hotkey eq "key_addhost" ); $self->retile_hosts("force") if ( $hotkey eq "key_retilehosts" ); $self->show_history() if ( $hotkey eq "key_history" ); $self->exit_prog() if ( $hotkey eq "key_quit" ); } return; } } } # look for a <Control>-d and no hosts, so quit $self->exit_prog() if ( $state =~ /Control/ && $keysym eq "d" and !%servers ); $self->update_display_text( $keycodetosym{$keysymdec} ) if ( $event eq "KeyPress" && $keycodetosym{$keysymdec} ); # for all servers foreach ( keys(%servers) ) { # if active if ( $servers{$_}{active} == 1 ) { $self->debug( 3, "Sending event $event with code $keycode (state=$state) to window $servers{$_}{wid}" ); $xdisplay->SendEvent( $servers{$_}{wid}, 0, $xdisplay->pack_event_mask($event), $xdisplay->pack_event( 'name' => $event, 'detail' => $keycode, 'state' => $state, 'event' => $servers{$_}{wid}, 'root' => $xdisplay->root(), 'same_screen' => 1, ) ) || warn("Error returned from SendEvent: $!"); } } $xdisplay->flush(); return $self; } sub create_menubar() { my ($self) = @_; $self->debug( 2, "create_menubar: started" ); $menus{bar} = $windows{main_window}->Menu(); $windows{main_window}->configure( -menu => $menus{bar}, ); $menus{file} = $menus{bar}->cascade( -label => 'File', -menuitems => [ [ "command", "Show History", -command => sub { $self->show_history; }, -accelerator => $self->config->{key_history}, ], [ "command", "Exit", -command => sub { $self->exit_prog }, -accelerator => $self->config->{key_quit}, ] ], -tearoff => 0, ); my $host_menu_items = [ [ "command", "Retile Windows", -command => sub { $self->retile_hosts }, -accelerator => $self->config->{key_retilehosts}, ], # [ "command", "Capture Terminal", -command => sub { $self->capture_terminal), ], [ "command", "Set all active", -command => sub { $self->set_all_active() }, ], [ "command", "Set half inactive", -command => sub { $self->set_half_inactive() }, ], [ "command", "Toggle active state", -command => sub { $self->toggle_active_state() }, ], [ "command", "Close inactive sessions", -command => sub { $self->close_inactive_sessions() }, ], [ "command", "Add Host(s) or Cluster(s)", -command => sub { $self->add_host_by_name, }, -accelerator => $self->config->{key_addhost}, ], [ "command", "Re-add closed session(s)", -command => sub { $self->re_add_closed_sessions() }, ], '' # this is needed as build_host_menu always drops the # last item ]; $menus{hosts} = $menus{bar}->cascade( -label => 'Hosts', -tearoff => 1, -menuitems => $host_menu_items ); $host_menu_static_items = scalar( @{$host_menu_items} ); $menus{send} = $menus{bar}->cascade( -label => 'Send', -tearoff => 1, ); $self->populate_send_menu(); $menus{help} = $menus{bar}->cascade( -label => 'Help', -menuitems => [ [ 'command', "About", -command => sub { $windows{help}->Show } ], [ 'command', "Documentation", -command => sub { $windows{manpage}->Show } ], ], -tearoff => 0, ); $windows{main_window}->bind( '<KeyPress>' => [ $self => 'key_event' ], ); $windows{main_window} ->bind( '<KeyRelease>' => [ $self => 'key_event' ], ); $self->debug( 2, "create_menubar: completed" ); } sub populate_send_menu_entries_from_xml { my ( $self, $menu, $menu_xml ) = @_; foreach my $menu_ref ( @{ $menu_xml->{menu} } ) { if ( $menu_ref->{menu} ) { $menus{ $menu_ref->{title} } = $menu->cascade( -label => $menu_ref->{title}, ); $self->populate_send_menu_entries_from_xml( $menus{ $menu_ref->{title} }, $menu_ref, ); if ( $menu_ref->{detach} && $menu_ref->{detach} =~ m/y/i ) { $menus{ $menu_ref->{title} }->menu->tearOffMenu()->raise; } } else { my $accelerator = undef; if ( $menu_ref->{accelerator} ) { $accelerator = $menu_ref->{accelerator}; } if ( $menu_ref->{toggle} ) { $menus{send}->checkbutton( -label => 'Use Macros', -variable => \$self->config->{macros_enabled}, -offvalue => 'no', -onvalue => 'yes', -accelerator => $accelerator, ); } else { my $command = undef; if ( $menu_ref->{command} ) { $command = sub { $self->send_text_to_all_servers( $menu_ref->{command}[0] ); }; } $menu->command( -label => $menu_ref->{title}, -command => $command, -accelerator => $accelerator, ); } } } return $self; } sub populate_send_menu { my ($self) = @_; # my @menu_items = (); if ( !-r $self->config->{send_menu_xml_file} ) { $self->debug( 2, 'Using default send menu' ); $menus{send}->checkbutton( -label => 'Use Macros', -variable => \$self->config->{macros_enabled}, -offvalue => 'no', -onvalue => 'yes', -accelerator => $self->config->{key_macros_enable}, ); $menus{send}->command( -label => 'Remote Hostname', -command => sub { $self->send_text_to_all_servers( $self->config->{macro_servername} ); }, -accelerator => $self->config->{key_clientname}, ); $menus{send}->command( -label => 'Local Hostname', -command => sub { $self->send_text_to_all_servers( $self->config->{macro_hostname} ); }, -accelerator => $self->config->{key_localname}, ); $menus{send}->command( -label => 'Username', -command => sub { $self->send_text_to_all_servers( $self->config->{macro_username} ); }, -accelerator => $self->config->{key_username}, ); $menus{send}->command( -label => 'Test Text', -command => sub { $self->send_text_to_all_servers( 'echo ClusterSSH Version: ' . $self->config->{macro_version} . $self->config->{macro_newline} ); }, ); $menus{send}->command( -label => 'Random Number', -command => sub { $self->send_variable_text_to_all_servers( sub { int( rand(1024) ) } ), ; }, ); } else { $self->debug( 2, 'Using xml send menu definition from ', $self->config->{send_menu_xml_file} ); eval { require XML::Simple; }; die 'Cannot load XML::Simple - has it been installed? ', $@ if ($@); my $xml = XML::Simple->new( ForceArray => 1, ); my $menu_xml = $xml->XMLin( $self->config->{send_menu_xml_file} ); $self->debug( 3, 'xml send menu: ', $/, $xml->XMLout($menu_xml) ); if ( $menu_xml->{detach} && $menu_xml->{detach} =~ m/y/i ) { $menus{send}->menu->tearOffMenu()->raise; } $self->populate_send_menu_entries_from_xml( $menus{send}, $menu_xml ); } return $self; } sub run { my ($self) = @_; $self->getopts; ### main ### # only get xdisplay if we got past usage and help stuff $xdisplay = X11::Protocol->new(); if ( !$xdisplay ) { die("Failed to get X connection\n"); } $self->debug( 2, "VERSION: $VERSION" ); # only use ssh_args from options if config file ssh_args not set AND # options is not the default value otherwise the default options # value is used instead of the config file if ( $self->config->{comms} eq 'ssh' ) { if ( $self->config->{ssh_args} ) { if ( $self->options->options && $self->options->options ne $self->options->options_default ) { $self->config->{ssh_args} = $self->options->options; } } else { $self->config->{ssh_args} = $self->options->options if ( $self->options->options ); } } $self->config->{terminal_args} = $self->options->term_args if ( $self->options->term_args ); if ( $self->config->{terminal_args} =~ /-class (\w+)/ ) { $self->config->{terminal_allow_send_events} = "-xrm '$1.VT100.allowSendEvents:true'"; } # if the user has asked for natural sorting we need to include an extra # module if ( $self->config()->{'use_natural_sort'} ) { eval { Module::Load::load('Sort::Naturally'); }; if ($@) { warn( "natural sorting requested but unable to load Sort::Naturally: $@\n" ); } else { $sort = sub { Sort::Naturally::nsort(@_) }; } } $self->config->dump() if ( $self->options->dump_config ); $self->evaluate_commands() if ( $self->options->evaluate ); $self->get_font_size(); $self->load_keyboard_map(); # read in normal cluster files $self->config->{extra_cluster_file} .= ',' . $self->options->cluster_file if ( $self->options->cluster_file ); $self->config->{extra_tag_file} .= ',' . $self->options->tag_file if ( $self->options->tag_file ); $self->cluster->get_cluster_entries( split /,/, $self->config->{extra_cluster_file} || '' ); $self->cluster->get_tag_entries( split /,/, $self->config->{extra_tag_file} || '' ); if ( defined $self->options->list ) { my $eol = $self->options->quiet ? ' ' : $/; my $tab = $self->options->quiet ? '' : "\t"; if ( !$self->options->list ) { print( 'Available cluster tags:', $/ ) unless ( $self->options->quiet ); print $tab, $_, $eol foreach ( sort( $self->cluster->list_tags ) ); my @external_clusters = $self->cluster->list_external_clusters; if (@external_clusters) { print( 'Available external command tags:', $/ ) unless ( $self->options->quiet ); print $tab, $_, $eol foreach ( sort(@external_clusters) ); print $/; } } else { print 'Tag resolved to hosts: ', $/ unless ( $self->options->quiet ); @servers = $self->resolve_names( $self->options->list ); foreach my $svr (@servers) { print $tab, $svr, $eol; } print $/; } $self->debug( 4, "Full clusters dump: ", $self->_dump_args_hash( $self->cluster->dump_tags ) ); $self->exit_prog(); } if (@ARGV) { @servers = $self->resolve_names(@ARGV); } else { #if ( my @default = $self->cluster->get_tag('default') ) { if ( $self->cluster->get_tag('default') ) { @servers # = $self->resolve_names( @default ); = $self->resolve_names( $self->cluster->get_tag('default') ); } } $self->create_windows(); $self->create_menubar(); $self->change_main_window_title(); $self->debug( 2, "Capture map events" ); $self->capture_map_events(); $self->debug( 0, 'Opening to: ', join( ' ', @servers ) ) if ( @servers && !$self->options->quiet ); $self->open_client_windows(@servers); # Check here if we are tiling windows. Here instead of in func so # can be tiled from console window if wanted if ( $self->config->{window_tiling} eq "yes" ) { $self->retile_hosts(); } else { $self->show_console(); } $self->build_hosts_menu(); $self->debug( 2, "Sleeping for a mo" ); select( undef, undef, undef, 0.5 ); $self->debug( 2, "Sorting focus on console" ); $windows{text_entry}->focus(); $self->debug( 2, "Marking main window as user positioned" ); $windows{main_window}->positionfrom('user') ; # user puts it somewhere, leave it there $self->debug( 2, "Setting up repeat" ); $self->setup_repeat(); # Start event loop $self->debug( 2, "Starting MainLoop" ); MainLoop(); # make sure we leave program in an expected way $self->exit_prog(); } 1; __END__ =pod =head1 NAME App::ClusterSSH - A container for functions of the ClusterSSH programs =head1 SYNOPSIS There is nothing in this module for public consumption. See documentation for F<cssh>, F<crsh>, F<ctel>, F<ccon>, or F<cscp> instead. =head1 DESCRIPTION This is the core for App::ClusterSSH. You should probably look at L<cssh> instead. =head1 SUBROUTINES/METHODS These methods are listed here to tidy up Pod::Coverage test reports but will most likely be moved into other modules. There are some notes within the code until this time. =over 2 =item REAPER =item add_host_by_name =item add_option =item build_hosts_menu =item capture_map_events =item capture_terminal =item change_main_window_title =item close_inactive_sessions =item config =item helper =item cluster =item create_menubar =item create_windows =item dump_config =item getopts =item list_tags =item evaluate_commands =item exit_prog =item get_clusters =item get_font_size =item get_keycode_state =item key_event =item load_config_defaults =item load_configfile =item load_keyboard_map =item new =item open_client_windows =item options =item parse_config_file =item pick_color =item populate_send_menu =item populate_send_menu_entries_from_xml =item re_add_closed_sessions =item remove_repeated_servers =item resolve_names =item retile_hosts =item run =item send_resizemove =item send_text =item send_text_to_all_servers =item set_all_active =item set_half_inactive =item setup_repeat =item send_variable_text_to_all_servers =item show_console =item show_history =item substitute_macros =item terminate_host =item toggle_active_state =item update_display_text =item write_default_user_config =back =head1 BUGS Please report any bugs or feature requests to C<bug-app-clusterssh at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=App-ClusterSSH>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc App::ClusterSSH You can also look for information at: =over 4 =item * RT: CPAN's request tracker L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-ClusterSSH> =item * AnnoCPAN: Annotated CPAN documentation L<http://annocpan.org/dist/App-ClusterSSH> =item * CPAN Ratings L<http://cpanratings.perl.org/d/App-ClusterSSH> =item * Search CPAN L<http://search.cpan.org/dist/App-ClusterSSH/> =back =head1 ACKNOWLEDGEMENTS Please see the THANKS file from the original distribution. =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 COPYRIGHT & LICENSE Copyright 1999-2015 Duncan Ferguson, all rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; ������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH��������������������������������������������������������������000755��001750��001750�� 0�12626321255� 20623� 5����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/Host.pm������������������������������������������������������000444��001750��001750�� 23722�12626321255� 22261� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Host; use strict; use warnings; use version; our $VERSION = version->new('0.03'); use Carp; use Net::hostent; use base qw/ App::ClusterSSH::Base /; our %ssh_hostname_for; our %ssh_configs_read; sub new { my ( $class, %args ) = @_; if ( !$args{hostname} ) { croak( App::ClusterSSH::Exception->throw( error => $class->loc('hostname is undefined') ) ); } # remove any keys undef values - must be a better way... foreach my $remove (qw/ port username geometry /) { if ( !$args{$remove} && grep {/^$remove$/} keys(%args) ) { delete( $args{$remove} ); } } my $self = $class->SUPER::new( ssh_config => "$ENV{HOME}/.ssh/config", %args ); # load in ssh hostname for later use if ( !%ssh_hostname_for || !$ssh_configs_read{ $self->{ssh_config} } ) { $ssh_configs_read{ $self->{ssh_config} } = 1; if ( open( my $ssh_config_fh, '<', $self->{ssh_config} ) ) { while ( my $line = <$ssh_config_fh> ) { chomp $line; next unless ( $line =~ m/^\s*host\s+(.*)/i ); # account for multiple declarations of hosts $ssh_hostname_for{$_} = 1 foreach ( split( /\s+/, $1 ) ); } close($ssh_config_fh); $self->debug( 5, 'Have the following ssh hostnames' ); $self->debug( 5, ' "', $_, '"' ) foreach ( sort keys %ssh_hostname_for ); } else { $self->debug( 3, 'Unable to read ', $self->{ssh_config}, ': ', $!, $/ ); } } return $self; } sub get_hostname { my ($self) = @_; return $self->{hostname}; } sub get_username { my ($self) = @_; return $self->{username} || q{}; } sub get_type { my ($self) = @_; if ( $self->check_ssh_hostname ) { return 'ssh_alias'; } return $self->{type} || q{}; } sub get_geometry { my ($self) = @_; return $self->{geometry} || q{}; } sub set_username { my ( $self, $new_username ) = @_; $self->{username} = $new_username; return $self; } sub get_port { my ($self) = @_; return $self->{port} || q{}; } sub set_port { my ( $self, $new_port ) = @_; $self->{port} = $new_port; return $self; } sub set_type { my ( $self, $type ) = @_; $self->{type} = $type; return $self; } sub set_geometry { my ( $self, $geometry ) = @_; $self->{geometry} = $geometry; return $self; } sub get_master { my ($self) = @_; return $self->{master} || q{}; } sub set_master { my ( $self, $new_master ) = @_; $self->{master} = $new_master; return $self; } sub get_realname { my ($self) = @_; if ( !$self->{realname} ) { if ( $self->get_type eq 'ssh_alias' ) { $self->{realname} = $self->{hostname}; } else { my $gethost_obj = gethostbyname( $self->{hostname} ); $self->{realname} = defined($gethost_obj) ? $gethost_obj->name() : $self->{hostname}; } } return $self->{realname}; } sub parse_host_string { my ( $self, $host_string ) = @_; my $parse_string = $host_string; $self->debug( 5, $self->loc( 'host_string=" [_1] "', $host_string ), ); # check for bracketed IPv6 addresses if ($host_string =~ m{ \A (?:(.*?)@)? # username@ (optional) \[([\w:]*)\] # [<sequence of chars>] (?::(\d+))? # :port (optional) (?:=(\d+\D\d+\D\d+\D\d))? # =geometry (optional) \z }xms ) { $self->debug( 5, $self->loc( 'bracketed IPv6: u=[_1] h=[_2] p=[_3] g=[_4]', $1, $2, $3, $4 ), ); return __PACKAGE__->new( parse_string => $parse_string, username => $1, hostname => $2, port => $3, geometry => $4, type => 'ipv6', ); } # check for standard IPv4 host.domain/IP address if ($host_string =~ m{ \A (?:(.*?)@)? # username@ (optional) ([\w\.-]*) # hostname[.domain[.domain] | 123.123.123.123 (?::(\d+))? # :port (optional) (?:=(\d+\D\d+\D\d+\D\d+))? # =geometry (optional) \z }xms ) { $self->debug( 5, $self->loc( 'std IPv4: u=[_1] h=[_2] p=[_3] g=[_4]', $1, $2, $3, $4 ), ); return __PACKAGE__->new( parse_string => $parse_string, username => $1, hostname => $2, port => $3, geometry => $4, type => 'ipv4', ); } # Check for unbracketed IPv6 addresses as best we can... my $username = q{}; my $geometry = q{}; my $port = q{}; # first, see if there is a username to grab if ( $host_string =~ s/\A(?:(.*?)@)// ) { # catch where @ is in host_string but no text before it $username = $1; } # check for any geometry settings if ( $host_string =~ s/(?:=(.*?)$)// ) { $geometry = $1; } # Check for a '/nnnn' port definition if ( $host_string =~ s!(?:/(\d+)$)!! ) { $port = $1; } # use number of colons as a possible indicator my $colon_count = $host_string =~ tr/://; # if there are 7 colons assume its a full IPv6 address # if its 8 then assumed full IPv6 address with a port # also catch localhost address here if ( $colon_count == 7 || $colon_count == 8 || $host_string eq '::1' ) { if ( $colon_count == 8 ) { $host_string =~ s/(?::(\d+?))$//; $port = $1; } $self->debug( 5, $self->loc( 'IPv6: u=[_1] h=[_2] p=[_3] g=[_4]', $username, $host_string, $port, $geometry, ), ); return __PACKAGE__->new( parse_string => $parse_string, username => $username, hostname => $host_string, port => $port, geometry => $geometry, type => 'ipv6', ); } if ( $colon_count > 1 && $colon_count < 8 ) { warn 'Ambiguous host string: "', $host_string, '"', $/; warn 'Assuming you meant "[', $host_string, ']"?', $/; $self->debug( 5, $self->loc( 'Ambiguous IPv6 u=[_1] h=[_2] p=[_3] g=[_4]', $username, $host_string, $port, $geometry, ) ); return __PACKAGE__->new( parse_string => $parse_string, username => $username, hostname => $host_string, port => $port, geometry => $geometry, type => 'ipv6', ); } # if we got this far, we didnt parse the host_string properly croak( App::ClusterSSH::Exception->throw( error => $self->loc( 'Unable to parse hostname from "[_1]"', $host_string ) ) ); } sub check_ssh_hostname { my ( $self, ) = @_; $self->debug( 4, 'Checking ssh hosts for hostname ', $self->get_hostname ); if ( $ssh_hostname_for{ $self->get_hostname } ) { return 1; } else { return 0; } } use overload ( q{""} => sub { my ($self) = @_; return $self->{hostname}; }, fallback => 1, ); 1; =pod =head1 NAME ClusterSSH::Host - Object representing a host. =head1 SYNOPSIS use ClusterSSH::Host; my $host = ClusterSSH::Host->new({ hostname => 'hostname', }); my $host = ClusterSSH::Host->parse_host_string('username@hostname:1234'); =head1 DESCRIPTION Object representing a host. Include details to contact the host such as hostname/ipaddress, username and port. =head1 METHODS =over 4 =item $host=ClusterSSH::Host->new ({ hostname => 'hostname' }) Create a new host object. 'hostname' is a required arg, 'username' and 'port' are optional. Raises exception if an error occurs. =item $host->get_hostname =item $host->get_username =item $host->get_port =item $host->get_master =item $host->get_geometry =item $host->get_type Return specific details about the host =item $host->set_username =item $host->set_port =item $host->set_master =item $host->set_geometry =item $host->set_type Set specific details about the host after its been created. =item get_realname If the server name provided is not an IP address (either IPv4 or IPv6) attempt to resolve it and retun the discovered names. =item get_givenname Alias to get_hostname, for use when C< get_realname > might return something different =item parse_host_string Given a host string, returns a host object. Parses hosts such as =item check_ssh_hostname Check the objects hostname to see whether or not it may be configured within the users F< $HOME/.ssh/config > configuration file =over 4 =item host =item 192.168.0.1 =item user@host =item user@192.168.0.1 =item host:port =item [1234:1234:1234::4567]:port =item 1234:1234:1234::4567 =back and so on. Cope with IPv4 and IPv6 addresses - raises a warning if the IPv6 address is ambiguous (i.e. in the last example, is the 4567 part of the IPv6 address or a port definition?) and assumes it is part of address. Use brackets to avoid seeing warning. =back =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; ����������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/Config.pm����������������������������������������������������000444��001750��001750�� 36354�12626321255� 22556� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Config; use strict; use warnings; use version; our $VERSION = version->new('0.02'); use Carp; use Try::Tiny; use FindBin qw($Script); use File::Copy; use base qw/ App::ClusterSSH::Base /; use App::ClusterSSH::Cluster; my $clusters; my %old_clusters; my @app_specific = (qw/ command title comms method parent /); # list of config items to not write out when writing the default config my @ignore_default_config = (qw/ user /); my %default_config = ( terminal => "xterm", terminal_args => "", terminal_title_opt => "-T", terminal_colorize => 1, terminal_bg_style => 'dark', terminal_allow_send_events => "-xrm '*.VT100.allowSendEvents:true'", terminal_font => "6x13", terminal_size => "80x24", use_hotkeys => "yes", key_quit => "Alt-q", key_addhost => "Control-Shift-plus", key_clientname => "Alt-n", key_history => "Alt-h", key_localname => "Alt-l", key_retilehosts => "Alt-r", key_macros_enable => "Alt-p", key_paste => "Control-v", key_username => "Alt-u", mouse_paste => "Button-2", auto_quit => "yes", auto_close => 5, use_natural_sort => 0, window_tiling => "yes", window_tiling_direction => "right", console_position => "", screen_reserve_top => 0, screen_reserve_bottom => 60, screen_reserve_left => 0, screen_reserve_right => 0, terminal_reserve_top => 5, terminal_reserve_bottom => 0, terminal_reserve_left => 5, terminal_reserve_right => 0, terminal_decoration_height => 10, terminal_decoration_width => 8, console => 'console', console_args => '', rsh => 'rsh', rsh_args => "", telnet => 'telnet', telnet_args => "", ssh => 'ssh', ssh_args => "", sftp => 'sftp', sftp_args => "", extra_cluster_file => '', external_cluster_command => '', unmap_on_redraw => "no", # Debian #329440 show_history => 0, history_width => 40, history_height => 10, command => q{}, max_host_menu_items => 30, macros_enabled => 'yes', macro_servername => '%s', macro_hostname => '%h', macro_username => '%u', macro_newline => '%n', macro_version => '%v', max_addhost_menu_cluster_items => 6, menu_send_autotearoff => 0, menu_host_autotearoff => 0, use_all_a_records => 0, send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu', # don't set username here as takes precendence over ssh config user => '', ); sub new { my ( $class, %args ) = @_; my $self = $class->SUPER::new(%default_config); ( my $comms = $Script ) =~ s/^c//; $comms = 'telnet' if ( $comms eq 'tel' ); $comms = 'console' if ( $comms eq 'con' ); $comms = 'ssh' if ( $comms eq 'lusterssh' ); $comms = 'sftp' if ( $comms eq 'sftp' ); # list of allowed comms methods if ( 'ssh rsh telnet sftp console' !~ m/\b$comms\b/ ) { $self->{comms} = 'ssh'; } else { $self->{comms} = $comms; } $self->{title} = uc($Script); $clusters = App::ClusterSSH::Cluster->new(); return $self->validate_args(%args); } sub validate_args { my ( $self, %args ) = @_; my @unknown_config = (); foreach my $config ( sort( keys(%args) ) ) { if ( grep /$config/, @app_specific ) { # $self->{$config} ||= 'unknown'; next; } if ( exists $self->{$config} ) { $self->{$config} = $args{$config}; } else { push( @unknown_config, $config ); } } if (@unknown_config) { croak( App::ClusterSSH::Exception::Config->throw( unknown_config => \@unknown_config, error => $self->loc( 'Unknown configuration parameters: [_1]' . $/, join( ',', @unknown_config ) ) ) ); } if ( !$self->{comms} ) { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( 'Invalid variable: comms' . $/ ), ), ); } if ( !$self->{ $self->{comms} } ) { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( 'Invalid variable: [_1]' . $/, $self->{comms} ), ), ); } # check the terminal has been found correctly if ( !-e $self->{terminal} ) { $self->{terminal} = $self->find_binary( $self->{terminal} ); } return $self; } sub parse_config_file { my ( $self, $config_file ) = @_; $self->debug( 2, 'Loading in config file: ', $config_file ); # if ( !-e $config_file || !-r $config_file ) { # croak( # App::ClusterSSH::Exception::Config->throw( # error => $self->loc( # 'File [_1] does not exist or cannot be read' . $/, # $config_file # ), # ), # ); # } # # open( CFG, $config_file ) or die("Couldnt open $config_file: $!"); # my $l; # my %read_config; # while ( defined( $l = <CFG> ) ) { # next # if ( $l =~ /^\s*$/ || $l =~ /^#/ ) # ; # ignore blank lines & commented lines # $l =~ s/#.*//; # remove comments from remaining lines # $l =~ s/\s*$//; # remove trailing whitespace # # # look for continuation lines # chomp $l; # if ( $l =~ s/\\\s*$// ) { # $l .= <CFG>; # redo unless eof(CFG); # } # # next unless $l =~ m/\s*(\S+)\s*=\s*(.*)\s*/; # my ( $key, $value ) = ( $1, $2 ); # if ( defined $key && defined $value ) { # $read_config{$key} = $value; # $self->debug( 3, "$key=$value" ); # } # } # close(CFG); my %read_config; %read_config = $self->load_file( type => 'config', filename => $config_file ); # grab any clusters from the config before validating it if ( $read_config{clusters} ) { $self->debug( 3, "Picked up clusters defined in $config_file" ); foreach my $cluster ( sort split / /, $read_config{clusters} ) { if ( $read_config{$cluster} ) { $clusters->register_tag( $cluster, split( / /, $read_config{$cluster} ) ); $old_clusters{$cluster} = $read_config{$cluster}; delete( $read_config{$cluster} ); } } delete( $read_config{clusters} ); } # tidy up entries, just in case $read_config{terminal_font} =~ s/['"]//g if ( $read_config{terminal_font} ); $self->validate_args(%read_config); } sub load_configs { my ( $self, @configs ) = @_; for my $config ( '/etc/csshrc', $ENV{HOME} . '/.csshrc', $ENV{HOME} . '/.clusterssh/config', ) { $self->parse_config_file($config) if ( -e $config ); } # write out default config file if necesasry try { $self->write_user_config_file(); } catch { warn $_, $/; }; # Attempt to load in provided config files. Also look for anything # relative to config directory for my $config (@configs) { next unless ($config); # can be null when passed from Getopt::Long $self->parse_config_file($config) if ( -e $config ); my $file = $ENV{HOME} . '/.clusterssh/config_' . $config; $self->parse_config_file($file) if ( -e $file ); } return $self; } sub write_user_config_file { my ($self) = @_; # attempt to move the old config file to one side if ( -f "$ENV{HOME}/.csshrc" ) { eval { move( "$ENV{HOME}/.csshrc", "$ENV{HOME}/.csshrc.DISABLED" ) }; if ($@) { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( 'Unable to move [_1] to [_2]: [_3]' . $/, '$HOME/.csshrc', '$HOME/.csshrc.DISABLED', $@ ), ) ); } else { warn( $self->loc( 'Moved [_1] to [_2]' . $/, '$HOME/.csshrc', '$HOME/.csshrc.DISABLED' ), ); } } return if ( -f "$ENV{HOME}/.clusterssh/config" ); if ( !-d "$ENV{HOME}/.clusterssh" ) { if ( !mkdir("$ENV{HOME}/.clusterssh") ) { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( 'Unable to create directory [_1]: [_2]' . $/, '$HOME/.clusterssh', $! ), ), ); } } # Debian #673507 - migrate clusters prior to writing ~/.clusterssh/config # in order to update the extra_cluster_file property if (%old_clusters) { if ( open( my $fh, ">", "$ENV{HOME}/.clusterssh/clusters" ) ) { print $fh '# ' . $self->loc('Tag definitions moved from old .csshrc file'), $/; foreach ( sort( keys(%old_clusters) ) ) { print $fh $_, ' ', join( ' ', $old_clusters{$_} ), $/; } close($fh); } else { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( 'Unable to write [_1]: [_2]' . $/, '$HOME/.clusterssh/clusters', $! ), ), ); } } if ( open( CONFIG, ">", "$ENV{HOME}/.clusterssh/config" ) ) { foreach ( sort( keys(%$self) ) ) { my $comment = ''; if ( grep /$_/, @ignore_default_config ) { $comment = '#'; } print CONFIG ${comment}, $_, '=', $self->{$_}, $/; } close(CONFIG); warn( $self->loc( 'Created new configuration file within [_1]' . $/, '$HOME/.clusterssh/' ) ); } else { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( 'Unable to write default [_1]: [_2]' . $/, '$HOME/.clusterssh/config', $! ), ), ); } return $self; } # search given directories for the given file sub search_dirs { my ( $self, $file, @directories ) = @_; my $path; foreach my $dir (@directories) { $self->debug( 3, "Looking for $file in $dir" ); if ( -f $dir . '/' . $file && -x $dir . '/' . $file ) { $path = $dir . '/' . $file; $self->debug( 2, "Found at $path" ); last; } } return $path; } # could use File::Which for some of this but we also search a few other places # just in case $PATH isnt set up right sub find_binary { my ( $self, $binary ) = @_; if ( !$binary ) { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc('argument not provided') . $/, ), ); } $self->debug( 2, "Looking for $binary" ); # if not found, strip the path and look again if ( $binary =~ m!^/! ) { if ( -f $binary ) { $self->debug( 2, "Already have full path to in $binary" ); return $binary; } else { $self->debug( 2, "Full path for $binary incorrect; searching" ); $binary =~ s!^.*/!!; } } my $path; if ( !-x $binary || substr( $binary, 0, 1 ) ne '/' ) { $path = $self->search_dirs( $binary, split( /:/, $ENV{PATH} ) ); # if it is on $PATH then no need to qualitfy the path to it # keep it as it is if ($path) { return $binary; } else { $path = $self->search_dirs( $binary, qw! /bin /sbin /usr/sbin /usr/bin /usr/local/bin /usr/local/sbin /opt/local/bin /opt/local/sbin ! ); } } else { $self->debug( 2, "Already configured OK" ); $path = $binary; } if ( !$path || !-f $path || !-x $path ) { croak( App::ClusterSSH::Exception::Config->throw( error => $self->loc( '"[_1]" binary not found - please amend $PATH or the cssh config file' . $/, $binary ), ), ); } chomp($path); return $path; } sub dump { my ( $self, $no_exit, ) = @_; $self->debug( 3, 'Dumping config to STDOUT' ); print( '# Configuration dump produced by "cssh -u"', $/ ); foreach my $key ( sort keys %$self ) { my $comment = ''; if ( grep /$key/, @app_specific ) { next; } if ( grep /$key/, @ignore_default_config ) { $comment = '#'; } print $comment, $key, '=', $self->{$key}, $/; } $self->exit if ( !$no_exit ); } #use overload ( # q{""} => sub { # my ($self) = @_; # return $self->{hostname}; # }, # fallback => 1, #); 1; =pod =head1 NAME ClusterSSH::Config - Object representing application configuration =head1 SYNOPSIS =head1 DESCRIPTION Object representing application configuration =head1 METHODS =over 4 =item $host=ClusterSSH::Config->new ({ }) Create a new configuration object. =item $config->parse_config_file('<filename>'); Read in configuration from given filename =item $config->validate_args(); Validate and apply all configuration loaded at this point =item $path = $config->search_dirs('<name>', @seaarch_directories); Search the given directories for the name given. Return undef if not found. =item $path = $config->find_binary('<name>'); Locate the binary <name> and return the full path. Doesn't just search $PATH in case the environment isn't set up correctly =item $config->load_configs(@extra); Load up configuration from known locations (warn if .csshrc file found) and load in option files as necessary. =item $config->write_user_config_file(); Write out default $HOME/.clusterssh/config file (before option config files are loaded). =item $config->dump() Write currently defined configuration to STDOUT =back =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/Base.pm������������������������������������������������������000444��001750��001750�� 20361�12626321255� 22212� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Base; use warnings; use strict; use Carp; use App::ClusterSSH::L10N; use Exception::Class ( 'App::ClusterSSH::Exception', 'App::ClusterSSH::Exception::Config' => { fields => 'unknown_config', }, 'App::ClusterSSH::Exception::Cluster', 'App::ClusterSSH::Exception::LoadFile', 'App::ClusterSSH::Exception::Helper', 'App::ClusterSSH::Exception::Getopt', ); # Don't use SVN revision as it can cause problems use version; our $VERSION = version->new('0.02'); my $debug_level = 4; our $language = 'en'; our $language_handle; our $app_configuration; sub new { my ( $class, %args ) = @_; my $config = { lang => 'en', debug => 0, %args, }; my $self = bless $config, $class; $self->set_debug_level( $config->{debug} ); $self->set_lang( $config->{lang} ); $self->debug( 7, $self->loc( 'Arguments to [_1]->new(): ', $class ), $self->_dump_args_hash(%args), ); return $self; } sub _dump_args_hash { my ( $class, %args ) = @_; my $string = $/; foreach ( sort( keys(%args) ) ) { $string .= "\t"; $string .= $_; $string .= ' => '; if ( ref( $args{$_} ) eq 'ARRAY' ) { $string .= "@{ $args{$_} }"; } else { $string .= $args{$_}; } $string .= ','; $string .= $/; } chomp($string); return $string; } sub _translate { my @args = @_; if ( !$language_handle ) { $language_handle = App::ClusterSSH::L10N->get_handle($language); } return $language_handle->maketext(@args); } sub loc { my ( $self, @args ) = @_; $_ ||= q{} foreach (@args); return _translate(@args); } sub set_lang { my ( $self, $lang ) = @_; $self->debug( 6, $self->loc( 'Setting language to "[_1]"', $lang ), ); return $self; } sub set_debug_level { my ( $self, $level ) = @_; if ( !defined $level ) { croak( App::ClusterSSH::Exception->throw( error => _translate('Debug level not provided') ) ); } if ( $level > 9 ) { $level = 9; } $debug_level = $level; return $self; } sub debug_level { my ($self) = @_; return $debug_level; } sub output { my ( $self, @text ) = @_; print @text, $/; return $self; } sub debug { my ( $self, $level, @text ) = @_; if ( $level <= $debug_level ) { $self->output(@text); } return $self; } sub exit { my ($self) = @_; exit; } sub config { my ($self) = @_; if ( !$app_configuration ) { croak( App::ClusterSSH::Exception->throw( _translate('config has not yet been set') ) ); } return $app_configuration; } sub set_config { my ( $self, $config ) = @_; if ($app_configuration) { croak( App::ClusterSSH::Exception->throw( _translate('config has already been set') ) ); } if ( !$config ) { croak( App::ClusterSSH::Exception->throw( _translate('passed config is empty') ) ); } $self->debug( 3, _translate('Setting app configuration') ); $app_configuration = $config; return $self; } sub load_file { my ( $self, %args ) = @_; if ( !$args{filename} ) { croak( App::ClusterSSH::Exception->throw( error => '"filename" arg not passed' ) ); } if ( !$args{type} ) { croak( App::ClusterSSH::Exception->throw( error => '"type" arg not passed' ) ); } $self->debug( 2, 'Loading in config file: ', $args{filename} ); if ( !-e $args{filename} ) { croak( App::ClusterSSH::Exception::LoadFile->throw( error => $self->loc( 'Unable to read file [_1]: [_2]' . $/, $args{filename}, $! ), ), ); } my $regexp = $args{type} eq 'config' ? qr/\s*(\S+)\s*=\s*(.*)/ : $args{type} eq 'cluster' ? qr/\s*(\S+)\s+(.*)/ : croak( App::ClusterSSH::Exception::LoadFile->throw( error => 'Unknown arg type: ', $args{type} ) ); open( my $fh, '<', $args{filename} ) or croak( App::ClusterSSH::Exception::LoadFile->throw( error => $self->loc( "Unable to read file [_1]: [_2]", $args{filename}, $! ) ), ); my %results; my $line; while ( defined( $line = <$fh> ) ) { next if ( $line =~ /^\s*$/ || $line =~ /^#/ ) ; # ignore blank lines & commented lines $line =~ s/\s*#.*//; # remove comments from remaining lines $line =~ s/\s*$//; # remove trailing whitespace # look for continuation lines chomp $line; if ( $line =~ s/\\\s*$// ) { $line .= <$fh>; redo unless eof($fh); } next unless $line =~ $regexp; my ( $key, $value ) = ( $1, $2 ); if ( defined $key && defined $value ) { if ( $results{$key} ) { $results{$key} .= ' ' . $value; } else { $results{$key} = $value; } $self->debug( 3, "$key=$value" ); $self->debug( 7, "entry now reads: $key=$results{$key}" ); } } close($fh) or croak( App::ClusterSSH::Exception::LoadFile->throw( error => "Could not close $args{filename} after reading: $!" ), ); return %results; } sub parent { my ($self) = @_; return $self->{parent}; } 1; =pod =head1 NAME App::ClusterSSH::Base - Base object provding utility functions =head1 SYNOPSIS use base qw/ App::ClusterSSH::Base /; # in object new method sub new { ( $class, $arg_ref ) = @_; my $self = $class->SUPER::new($arg_ref); return $self; } =head1 DESCRIPTION Base object to provide some utility functions on objects - should not be used directly =head1 METHODS These extra methods are provided on the object =over 4 =item $obj = App::ClusterSSH::Base->new({ arg => val, }); Creates object. In higher debug levels the args are printed out. =item $obj->id Return the unique id of the object for use in subclasses, such as $info_for{ $self->id } = $info =item $obj->debug_level(); Returns current debug level =item $obj->set_debug_level( n ) Set debug level to 'n' for all child objects. =item $obj->debug($level, @text) Output @text on STDOUT if $level is the same or lower that debug_level =item $obj->set_lang Set the Locale::Maketext language. Defaults to 'en'. Expects the App::ClusterSSH/L10N/{lang}.pm module to exist and contain all relevant translations, else defaults to English. =item $obj->loc('text to translate [_1]') Using the App::ClusterSSH/L10N/{lang}.pm module convert the given text to appropriate language. See L<App::ClusterSSH::L10N> for more details. Essentially a wrapper to maketext in Locale::Maketext =item $obj->output(@); Output text on STDOUT. =item $ovj->parent; Reutrned the object that is the parent of this one, if it was set when the object was created =item $obj->exit; Stub to allow program to exit neatly from wherever in the code =item $config = $obj->config; Returns whatever configuration object has been set up. Croaks if set_config hasnt been called =item $obj->set_config($config); Set the config to the given value - croaks if has already been called =item %results = $obj->load_file( filename => '/path/to/file', type => '(cluster|config}' ) Load in the specified file and return a hash, parsing the file depending on wther it is a config file (key = value) or cluster file (key value) =back =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/Helper.pm����������������������������������������������������000444��001750��001750�� 7612�12626321255� 22543� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Helper; use strict; use warnings; use version; our $VERSION = version->new('0.02'); use Carp; use Try::Tiny; use base qw/ App::ClusterSSH::Base /; sub new { my ( $class, %args ) = @_; my $self = $class->SUPER::new(%args); return $self; } sub script { my ( $self, $config ) = @_; if ( !defined $config || !ref $config || ref $config ne "App::ClusterSSH::Config" ) { croak( App::ClusterSSH::Exception::Helper->throw( error => 'No configuration provided or in wrong format', ), ); } foreach my $arg ( "comms", $config->{comms}, $config->{comms} . '_args', 'command', 'auto_close' ) { if ( !defined $config->{$arg} ) { croak( App::ClusterSSH::Exception::Helper->throw( error => "Config '$arg' not provided", ), ); } } my $comms = $config->{ $config->{comms} }; my $comms_args = $config->{ $config->{comms} . '_args' }; my $config_command = $config->{command}; my $autoclose = $config->{auto_close}; my $postcommand = $autoclose ? "echo Sleeping for $autoclose seconds; sleep $autoclose" : "echo Press RETURN to continue; read IGNORE" ; # : "sleep $autoclose"; my $script = <<" HERE"; my \$pipe=shift; my \$svr=shift; my \$user=shift; my \$port=shift; my \$mstr=shift; my \$command="$comms $comms_args "; open(PIPE, ">", \$pipe) or die("Failed to open pipe: \$!\\n"); print PIPE "\$\$:\$ENV{WINDOWID}" or die("Failed to write to pipe: $!\\n"); close(PIPE) or die("Failed to close pipe: $!\\n"); if(\$svr =~ m/==\$/) { \$svr =~ s/==\$//; warn("\\nWARNING: failed to resolve IP address for \$svr.\\n\\n" ); sleep 5; } if(\$mstr) { unless("$comms" ne "console") { \$mstr = \$mstr ? "-M \$mstr " : ""; \$command .= \$mstr; } } if(\$user) { unless("$comms" eq "telnet") { \$user = \$user ? "-l \$user " : ""; \$command .= \$user; } } if("$comms" eq "telnet") { \$command .= "\$svr \$port"; } else { if (\$port) { \$command .= "-p \$port \$svr"; } else { \$command .= "\$svr"; } } if("$config_command") { \$command .= " \\\"$config_command\\\""; } \$command .= " ; $postcommand"; # provide some info for debugging purposes warn("Running: \$command\\n"); exec(\$command); HERE $self->debug( 4, $script ); $self->debug( 2, 'Helper script done' ); return $script; } #use overload ( # q{""} => sub { # my ($self) = @_; # return $self->{hostname}; # }, # fallback => 1, #); 1; =pod =head1 NAME ClusterSSH::Helper - Object representing helper script =head1 SYNOPSIS =head1 DESCRIPTION Object representing application configuration =head1 METHODS =over 4 =item $host=ClusterSSH::Helper->new ({ }) Create a new helper object. =item $host=ClusterSSH::Helper->script ({ }) Return the helper script =back =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; ����������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/Getopt.pm����������������������������������������������������000444��001750��001750�� 122037�12626321255� 22625� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Getopt; use strict; use warnings; use version; our $VERSION = version->new('0.01'); use Carp; use Try::Tiny; use Pod::Usage; use Getopt::Long qw(:config no_ignore_case bundling no_auto_abbrev); use FindBin qw($Script); use base qw/ App::ClusterSSH::Base /; sub new { my ( $class, %args ) = @_; # basic setup that is over-rideable by each script as needs may be # different depending ont he command used my %setup = ( usage => [ '-h|--help', '[options] [[user@]<server>[:port]|<tag>] [...] ', ], ); my $self = $class->SUPER::new( %setup, %args ); # options common to all connection types $self->{command_options} = {}; $self->add_common_options; return $self; } sub add_option { my ( $self, %args ) = @_; my $spec = $args{spec}; if ( !$spec ) { croak( App::ClusterSSH::Exception::Getopt->throw( error => 'No "spec" passed to add_option', ), ); } my ( $option, $arg ) = $spec =~ m/^(.*?)(?:[\+=:](.*))?$/; if ($arg) { my $arg_open = '<'; my $arg_close = '>'; if ( $args{arg_optional} ) { $arg_open = '['; $arg_close = ']'; } my $arg_type = defined $args{arg_desc} ? "${arg_open}$args{arg_desc}${arg_close}" : undef; $arg =~ s/\+/[[...] || <INTEGER>]/g; if ( $arg eq 'i' ) { $arg = defined $arg_type ? $arg_type : $arg_open . $self->loc('INTEGER') . $arg_close; } if ( $arg eq 's' ) { $arg = defined $arg_type ? "'$arg_type'" : "'" . $arg_open . $self->loc('STRING') . $arg_close . "'"; } } my ( $desc, $long, $short, $accessor ); foreach my $item ( split /\|/, $option ) { $desc .= ', ' if ($desc); # assumption - long options are 2 or more chars if ( length($item) == 1 ) { $desc .= "-$item"; $short = "-$item"; } else { $desc .= "--$item"; $long = "--$item"; if ( !$accessor ) { $accessor = $item; } } $desc .= " $arg" if ($arg); $short .= " $arg" if ( $short && $arg ); $long .= " $arg" if ( $long && $arg ); } $args{option_desc} = $desc; $args{option_short} = $short; $args{option_long} = $long; $args{accessor} = $accessor if ( !defined $args{no_accessor} ); $self->{command_options}->{$spec} = \%args; return $self; } # For options common to everything sub add_common_options { my ($self) = @_; $self->add_option( spec => 'version|v', help => $self->loc("Show version information and exit"), no_accessor => 1, ); $self->add_option( spec => 'usage|?', help => $self->loc('Show synopsis and exit'), no_accessor => 1, ); $self->add_option( spec => 'help|h', help => $self->loc("Show basic help text and exit"), no_accessor => 1, ); $self->add_option( spec => 'man|H', help => $self->loc("Show full help text (the man page) and exit"), no_accessor => 1, ); $self->add_option( spec => 'debug:+', help => $self->loc( "Enable debugging. Either a level can be provided or the option can be repeated multiple times. Maximum level is 4." ), default => 0, ); $self->add_option( spec => 'generate-pod', no_accessor => 1, hidden => 1, ); $self->add_option( spec => 'autoclose|K=i', arg_desc => 'seconds', help => $self->loc( 'Number of seconds to wait before closing finished terminal windows.' ), ); $self->add_option( spec => 'autoquit|q', help => $self->loc( 'Toggle automatically quiting after the last client window has closed (overriding the config file).' ), ); $self->add_option( spec => 'evaluate|e=s', arg_desc => '[user@]<host>[:port]', help => $self->loc( 'Display and evaluate the terminal and connection arguments to display any potential errors. The <hostname> is required to aid the evaluation.' ), ); $self->add_option( spec => 'config-file|C=s', arg_desc => 'filename', help => $self->loc( 'Use supplied file as additional configuration file (see also L</"FILES">).' ), ); $self->add_option( spec => 'cluster-file|c=s', arg_desc => 'filename', help => $self->loc( 'Use supplied file as additional cluster file (see also L</"FILES">).' ), ); $self->add_option( spec => 'tag-file|r=s', arg_desc => 'filename', help => $self->loc( 'Use supplied file as additional tag file (see also L</"FILES">)' ), ); $self->add_option( spec => 'font|f=s', arg_desc => 'font', help => $self->loc( 'Specify the font to use in the terminal windows. Use standard X font notation such as "5x8".' ), ); $self->add_option( spec => 'list|L:s', help => $self->loc( 'List available cluster tags. Tag is optional. If a tag is provided then hosts for that tag are listed. NOTE: format of output changes when using "--quiet" or "-Q" option.' ), arg_desc => 'tag', arg_optional => 1, ); $self->add_option( spec => 'dump-config|d', help => $self->loc( 'Dump the current configuration in the same format used by the F<$HOME/.clusterssh/config> file.' ), ); $self->add_option( spec => 'port|p=i', arg_desc => 'port', help => $self->loc('Specify an alternate port for connections.'), ); $self->add_option( spec => 'show-history|s', help => $self->loc('Show history within console window.'), ); $self->add_option( spec => 'tile|g', help => $self->loc('Toggle window tiling (overriding the config file).'), ); $self->add_option( spec => 'term-args|t=s', help => $self->loc( 'Specify arguments to be passed to terminals being used.'), ); $self->add_option( spec => 'title|T=s', arg_desc => 'title', help => $self->loc( 'Specify the initial part of the title used in the console and client windows.' ), ); $self->add_option( spec => 'unique-servers|u', help => $self->loc( 'Toggle connecting to each host only once when a hostname has been specified multiple times.' ), ); $self->add_option( spec => 'use-all-a-records|A', help => $self->loc( 'If a hostname resolves to multiple IP addresses, toggle whether or not to connect to all of them, or just the first one (see also config file entry).' ), ); $self->add_option( spec => 'quiet|Q', help => $self->loc('Do not output extra text when using some options'), ); return $self; } # For options common to ssh sessions sub add_common_ssh_options { my ($self) = @_; $self->add_option( spec => 'options|o=s', help => $self->loc( 'Specify arguments to be passed to ssh when making the connection. B<NOTE:> options for ssh should normally be put into the ssh configuration file; see C<ssh_config> and F<$HOME/.ssh/config> for more details.' ), default => '-x -o ConnectTimeout=10', ); return $self; } # For options that work in ssh, rsh type consoles, but not telnet or console sub add_common_session_options { my ($self) = @_; $self->add_option( spec => 'username|l=s', arg_desc => 'username', help => $self->loc( 'Specify the default username to use for connections (if different from the currently logged in user). B<NOTE:> will be overridden by <user>@<host>.' ), ); $self->add_option( spec => 'action|a=s', arg_desc => 'command', help => $self->loc( "Run the command in each session, e.g. C<-a 'vi /etc/hosts'> to drop straight into a vi session." ), ); return $self; } sub getopts { my ($self) = @_; my $options = {}; pod2usage( -verbose => 1 ) if ( !GetOptions( $options, keys( %{ $self->{command_options} } ) ) ); pod2usage( -verbose => 0 ) if ( $options->{'?'} || $options->{usage} ); pod2usage( -verbose => 1 ) if ( $options->{'h'} || $options->{help} ); pod2usage( -verbose => 2 ) if ( $options->{H} || $options->{man} ); # record what was given on the command line in case this # object is ever dumped out $self->{options_parsed} = $options; if ( $options->{'generate-pod'} ) { $self->_generate_pod; $self->exit; } if ( $options->{version} ) { print 'Version: ', $self->parent->VERSION, $/; $self->exit; } $options->{debug} ||= 0; $options->{debug} = 4 if ( $options->{debug} && $options->{debug} > 4 ); # Now all options are set to the correct values, generate accessor methods foreach my $option ( sort keys( %{ $self->{command_options} } ) ) { my $accessor = $self->{command_options}->{$option}->{accessor}; my $default = $self->{command_options}->{$option}->{default}; if ( my $acc = $accessor ) { $accessor =~ s/-/_/g; no strict 'refs'; # hide warnings when getopts is run multiple times, esp. for testing no warnings 'redefine'; *$accessor = sub { return defined $options->{$acc} ? $options->{$acc} : $default; # defined $options->{$acc} ? $options->{$acc} # : defined $self->{command_options}->{$acc}->{default} # ? $self->{command_options}->{$acc}->{default} # : undef; }; my $accessor_default = $accessor . '_default'; *$accessor_default = sub { return $default; }; } } $self->set_debug_level( $self->debug ); $self->parent->config->load_configs( $self->config_file ); if ( $self->use_all_a_records ) { $self->parent->config->{use_all_a_records} = !$self->parent->config->{use_all_a_records} || 0; } if ( $self->unique_servers ) { $self->parent->config->{unique_servers} = !$self->parent->config->{unique_servers} || 0; } $self->parent->config->{title} = $self->title if ( $self->title ); $self->parent->config->{port} = $self->port if ( $self->port ); # note, need to check if these actions can be performed as they are # not common acorss all communiction methods $self->parent->config->{command} = $self->action if ( $self->can('action') && $self->action ); $self->parent->config->{user} = $self->username if ( $self->can('username') && $self->username ); $self->parent->config->{terminal_font} = $self->font if ( $self->font ); $self->parent->config->{terminal_args} = $self->term_args if ( $self->term_args ); $self->parent->config->{show_history} = 1 if ( $self->show_history ); $self->parent->config->{auto_close} = $self->autoclose if ( $self->autoclose ); if ( $self->autoquit ) { $self->parent->config->{auto_quit} = !$self->parent->config->{auto_quit} || 0; } if ( $self->tile ) { $self->parent->config->{window_tiling} = !$self->parent->config->{window_tiling} || 0; } return $self; } sub output { my (@text) = @_; confess if ( exists $text[1] && !$text[1] ); print @text, $/, $/; } # generate valid POD from all the options and send to STDOUT # so build process can create pod files for the distribution sub _generate_pod { my ($self) = @_; output $/ , "=pod"; output '=head1 ', $self->loc('NAME'); output "$Script - ", $self->loc("Cluster administration tool"); output '=head1 ', $self->loc('SYNOPSIS'); # build the synopsis print "$Script "; foreach my $longopt ( sort keys( %{ $self->{command_options} } ) ) { next if ( $self->{command_options}->{$longopt}->{hidden} ); print '[' . ( $self->{command_options}->{$longopt}->{option_short} || $self->{command_options}->{$longopt}->{option_long} ) . '] '; } print $/, $/; output '=head1 ', $self->loc('DESCRIPTION'); output $self->loc( q{The command opens an administration console and an xterm to all specified hosts. Any text typed into the administration console is replicated to all windows. All windows may also be typed into directly. This tool is intended for (but not limited to) cluster administration where the same configuration or commands must be run on each node within the cluster. Performing these commands all at once via this tool ensures all nodes are kept in sync. Connections are opened using [_1] which must be correctly installed and configured. Extra caution should be taken when editing files as lines may not necessarily be in the same order; assuming line 5 is the same across all servers and modifying that is dangerous. It's better to search for the specific line to be changed and double-check all terminals are as expected before changes are committed.}, $self->parent->config->{comms} ); output '=head2 ', $self->loc('Further Notes'); output $self->loc('Please also see "KNOWN BUGS".'); output '=over'; output '=item *'; output $self->loc( q{The dotted line on any sub-menu is a tear-off, i.e. click on it and the sub-menu is turned into its own window.} ); output '=item *'; output $self->loc( q{Unchecking a hostname on the Hosts sub-menu will unplug the host from the cluster control window, so any text typed into the console is not sent to that host. Re-selecting it will plug it back in.} ); output '=item *'; output $self->loc( q{If your window manager menu bars are obscured by terminal windows see the C<screen_reserve_XXXXX> options in the [_1] file (see [_2]).}, 'F<$HOME/.clusterssh/config>', 'L</"FILES">' ); output '=item *'; output $self->loc( q{If the terminals overlap too much see the C<terminal_reserve_XXXXX> options in the [_1] file (see [_2]).}, 'F<$HOME/.clusterssh/config>', 'L</"FILES">' ); output '=item *'; output $self->loc( q{When using ClusterSSH on a large number of systems to connect to a single system using an SSH utility (e.g. you issue a command to to copy a file using scp from the remote computers to a single host) and when these connections require authentication (i.e. you are going to authenticate with a password), the sshd daemon at that location may refuse connections after the number C<MaxStartups> limit in F<sshd_config> is exceeded. (If this value is not set, it defaults to 10). This is expected behavior; sshd uses this mechanism to prevent DoS attacks from unauthenticated sources. Please tune sshd_config and reload the SSH daemon, or consider using the [_1] mechanism for authentication if you encounter this problem.}, 'F<~/.ssh/authorized_keys>' ); output '=item *'; output $self->loc( q{If client windows fail to open, try running: [_1] This will test the mechanisms used to open windows to hosts. This could be due to either the [_2] terminal option which enables [_3] (some terminals do not require this option, other terminals have another method for enabling it - see your terminal documentation) or the configuration of [_4].}, "C<< $Script -e {single host name} >>", 'C<-xrm>', 'C<AllowSendEvents>', 'C<' . $self->parent->config->{comms} . '>', ); output '=back'; output '=head1 ' . $self->loc('OPTIONS'); output $self->loc( "Some of these options may also be defined within the configuration file. Default options are shown as appropriate." ); output '=over'; foreach my $longopt ( sort keys( %{ $self->{command_options} } ) ) { next if ( $self->{command_options}->{$longopt}->{hidden} ); output '=item ', $self->{command_options}->{$longopt}->{option_desc}; output $self->{command_options}->{$longopt}->{help} || 'No help'; if ( $self->{command_options}->{$longopt}->{default} ) { output $self->loc('Default'), ': ', $self->{command_options}->{$longopt}->{default}, $/, $/; } } output '=back'; output '=head1 ' . $self->loc('ARGUMENTS'); output $self->loc('The following arguments are supported:'); output '=over'; output '=item [user@]<hostname>[:port] ...'; output $self->loc( 'Open an xterm to the given hostname and connect to the administration console. The optional port number can be used if the server is not listening on the standard port.' ); output '=item <tag> ...'; output $self->loc( 'Open a series of xterms defined by <tag> in one of the supplementary configuration files (see [_1]). B<Note:> specifying a username on a cluster tag will override any usernames defined in the cluster.', 'L</"FILES">' ); output '=back'; output '=head1 ' . $self->loc('KEY SHORTCUTS'); output $self->loc( 'The following key shortcuts are available within the console window, and all of them may be changed via the configuration files.' ); output '=over'; output '=item ', $self->parent->config->{key_addhost}; output $self->loc( q{Open the 'Add Host(s) or Cluster(s)' dialogue box. Multiple host or cluster names can be entered, separated by spaces.} ); output '=item ', $self->parent->config->{key_clientname}; output $self->loc( q{Paste in the hostname part of the specific connection string to each client, minus any username or port, e.g. C<< scp /etc/hosts server:files/<Alt-n>.hosts >> would replace the <Alt-n> with the client's name in each window.} ); output '=item ', $self->parent->config->{key_localname}; output $self->loc( q{Paste in the hostname of the server cssh is ebing run on}); output '=item ', $self->parent->config->{key_quit}; output $self->loc( 'Quit the program and close all connections and windows.'); output '=item ', $self->parent->config->{key_retilehosts}; output $self->loc(q{Retile all the client windows.}); output '=item ', $self->parent->config->{key_username}; output $self->loc(q{Paste in the username for the connection}); output '=back'; output '=head1 ' . $self->loc('EXAMPLES'); output '=over'; output '=item ', $self->loc(q{Open up a session to 3 servers}); output q{S<$ } . $Script . q{ server1 server2 server3>}; output '=item ', $self->loc( q{Open up a session to a cluster of servers identified by the tag 'farm1' and give the controlling window a specific title, where the tag is defined in one of the default configuration files} ); output q{S<$ } . $Script . q{ -T 'Web Farm Cluster 1' farm1>}; output '=item ', $self->loc( q{Connect to different servers using different login names. NOTE: this can also be achieved by setting up appropriate options in the configuration files. Do not close the console when the last terminal exits.} ); output q{S<$ } . $Script . q{ user1@server1 admin@server2>}; output '=item ', $self->loc( q{Open up a cluster defined in a non-default configuration file}); output q{S<$ } . $Script . q{ -c $HOME/cssh.extra_clusters db_cluster>}; output '=item ', $self->loc( q{Override the configured/default port to use 2022 instead}); output q{S<$ } . $Script . q{ -p 2022 server1 server2>}; output '=back'; output '=head1 ' . $self->loc('FILES'); output '=over'; output q{=item F</etc/clusters>, F<$HOME/.clusterssh/clusters>}; output $self->loc( q{These files contain a list of tags to server names mappings. When any name is used on the command line it is checked to see if it is a tag. If it is a tag, then the tag is replaced with the list of servers. The format is as follows:} ); output 'S<< <tag> [user@]<server>[:port] [user@]<server>[:port] [...] >>'; output $self->loc( 'e.g. # List of servers in live live admin1@server1 admin2@server2:2022 server3 server4' ); output $self->loc( q{All comments (marked by a #) and blank lines are ignored. Tags may be nested, but be aware of using recursive tags as they are not checked for.} ); output $self->loc( q{Extra cluster files may also be specified either as an option on the command line (see [_1]) or in the user's [_2] file (see [_3] configuration option).}, 'C<cluster-file>', 'F<$HOME/.clusterssh/config>', 'C<extra_cluster_file>' ); output $self->loc( 'B<NOTE:> the last tag read overwrites any pre-existing tag of that name.' ); output $self->loc( 'B<NOTE:> there is a special cluster tag called [_1] - any tags or hosts included within this tag will be automatically opened if nothing is specified on the command line.', 'C<default>' ); output q{=item F</etc/tags>, F<$HOME/.clusterssh/tags>}; output $self->loc( q{Very similar to [_1] files but the definition is reversed. The format is:}, 'F<clusters>' ); output 'S<< <host> <tag> [...] >>'; output $self->loc( q{This allows one host to be specified as a member of a number of tags. This format can be clearer than using [_1] files.}, 'F<clusters>' ); output $self->loc( q{Extra tag files may be specified either as an option (see [_1]) or within the user's [_2] file (see [_3] configuration option).}, 'C<tag-file>', 'F<$HOME/.clusterssh/config>', 'C<extra_tag_file>' ); output $self->loc('B<NOTE:> All tags are added together'); output q{=item F</etc/csshrc> & F<$HOME/.clusterssh/config>}; output $self->loc( q{This file contains configuration overrides - the defaults are as marked. Default options are overwritten first by the global file, and then by the user file.} ); output $self->loc( 'B<NOTE:> values for entries do not need to be quoted unless it is required for passing arguments, e.g.' ); output q{C<< terminal_allow_send_events="-xrm '*.VT100.allowSendEvents:true'" >>}; output $self->loc('should be written as'); output q{C<< terminal_allow_send_events=-xrm '*.VT100.allowSendEvents:true' >>}; output '=over'; output '=item auto_close = 5'; output $self->loc( 'Close terminal window after this many seconds. If set to 0 will instead wait on input from the user in each window before closing. See also [_1] and [_2]', 'L<--autoclose>', '--no-autoclose' ); output '=item auto_quit = 1'; output $self->loc( 'Automatically quit after the last client window closes. Set to 0 to disable. See also [_1]', 'L<--autoquit>', ); output '=item comms = ' . $self->parent->config->{comms}; output $self->loc( 'Sets the default communication method (initially taken from the name of the program, but can be overridden here).' ); output '=item console_position = <null>'; output $self->loc( q{Set the initial position of the console - if empty then let the window manager decide. Format is '+<x>+<y>', i.e. '+0+0' is top left hand corner of the screen, '+0-70' is bottom left hand side of screen (more or less).} ); output '=item external_cluster_command = <null>'; output $self->loc( q{Define the full path to an external command that can be used to resolve tags to host names. This command can be written in any language. The script must accept a list of tags to resolve and output a list of hosts (space separated on a single line). Any tags that cannot be resolved should be returned unchanged. A non-0 exit code will be counted as an error, a warning will be printed and output ignored. If the external command is given a C<-L> option it should output a list of tags (space separated on a single line) it can resolve} ); output '=item extra_cluster_file = <null>'; output $self->loc( q{Define an extra cluster file in the format of [_1]. Multiple files can be specified, separated by commas. Both ~ and $HOME are acceptable as a reference to the user's home directory, e.g.}, 'F</etc/clusters>' ); output 'C<< extra_cluster_file = ~/clusters, $HOME/clus >>'; output '=item key_addhost = Control-Shift-plus'; output $self->loc( q{Default key sequence to open AddHost menu. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item key_clientname = Alt-n'; output $self->loc( q{Default key sequence to send cssh client names to client. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item key_localname = Alt-l'; output $self->loc( q{Default key sequence to send hostname of local server to client. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item key_paste = Control-v'; output $self->loc( q{Default key sequence to paste text into the console window. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item key_quit = Control-q'; output $self->loc( q{Default key sequence to quit the program (will terminate all open windows). See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item key_retilehosts = Alt-r'; output $self->loc( q{Default key sequence to retile host windows. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item key_username = Alt-u'; output $self->loc( q{Default key sequence to send username to client. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item macro_servername = %s'; output '=item macro_hostname = %h'; output '=item macro_username = %u'; output '=item macro_newline = %n'; output '=item macro_version = %v'; output $self->loc( q{Change the replacement macro used when either using a 'Send' menu item, or when pasting text into the main console.} ); output '=item macros_enabled = yes'; output $self->loc( q{Enable or disable macro replacement. Note: this affects all the [_1] variables above.}, 'C<macro_*>' ); output '=item max_addhost_menu_cluster_items = 6'; output $self->loc( q{Maximum number of entries in the 'Add Host' menu cluster list before scrollbars are used} ); output '=item max_host_menu_items = 30'; output $self->loc( q{Maximum number of hosts to put into the host menu before starting a new column} ); output '=item menu_host_autotearoff = 0'; output '=item menu_send_autotearoff = 0'; output $self->loc( q{When set to non-0 will automatically tear-off the host or send menu at program start} ); output '=item mouse_paste = Button-2 (middle mouse button)'; output $self->loc( q{Default key sequence to paste text into the console window using the mouse. See [_1] for more information.}, 'L<KEY SHORTCUTS>' ); output '=item rsh = /path/to/rsh'; output '=item ssh = /path/to/ssh'; output '=item telnet = /path/to/telnet'; output $self->loc( q{Set the path to the specific binary to use for the communication method, else uses the first match found in [_1]}, 'C<$PATH>' ); output '=item rsh_args = <blank>'; output '=item ssh_args = "-x -o ConnectTimeout=10"'; output '=item telnet_args = <blank>'; output $self->loc( q{Sets any arguments to be used with the communication method (defaults to ssh arguments). B<NOTE:> The given defaults are based on OpenSSH, not commercial ssh software. B<NOTE:> Any "generic" change to the method (e.g., specifying the ssh port to use) should be done in the medium's own config file (see [_1] and [_2]).}, 'C<ssh_config>', 'F<$HOME/.ssh/config>' ); output '=item screen_reserve_top = 0'; output '=item screen_reserve_bottom = 60'; output '=item screen_reserve_left = 0'; output '=item screen_reserve_right = 0'; output $self->loc( q{Number of pixels from the screen's side to reserve when calculating screen geometry for tiling. Setting this to something like 50 will help keep cssh from positioning windows over your window manager's menu bar if it draws one at that side of the screen.} ); output '=item terminal = /path/to/xterm'; output $self->loc(q{Path to the X-Windows terminal used for the client.}); output '=item terminal_args = <blank>'; output $self->loc( q{Arguments to use when opening terminal windows. Otherwise takes defaults from [_1] or [_2] file.}, 'F<$HOME/.Xdefaults>', 'F<$HOME/.Xresources>' ); output '=item terminal_chdir = 0'; output $self->loc( q{When non-0, set the working directory for each terminal as per '[_1]'}, 'L<terminal_chdir_path>' ); output '=item terminal_chdir_path = $HOME/.clusterssh/work/%s'; output $self->loc( q{Path to use as working directory for each terminal when '[_1]' is enabled. The path provided is passed through the macro parser (see the section above on '[_2]'.}, 'L<terminal_chdir>', 'L<macros_enabled>', ); output '=item terminal_font = 6x13'; output $self->loc( q{Font to use in the terminal windows. Use standard X font notation.} ); output '=item terminal_reserve_top = 5'; output '=item terminal_reserve_bottom = 0'; output '=item terminal_reserve_left = 5'; output '=item terminal_reserve_right = 0'; output $self->loc( q{Number of pixels from the terminal's side to reserve when calculating screen geometry for tiling. Setting these will help keep cssh from positioning windows over your scroll and title bars or otherwise overlapping the windows too much.} ); output '=item terminal_colorize = 1'; output $self->loc( q{If set to 1 (the default), then "-bg" and "-fg" arguments will be added to the terminal invocation command-line. The terminal will be colored in a pseudo-random way based on the host name; while the color of a terminal is not easily predicted, it will always be the same color for a given host name. After a while, you will recognize hosts by their characteristic terminal color.} ); output '=item terminal_bg_style = dark'; output $self->loc( q{If set to [_1], the terminal background will be set to black and the foreground to the pseudo-random color. If set to [_2], then the foreground will be black and the background the pseudo-random color. If terminal_colorize is [_3], then this option has no effect.}, 'C<dark>', 'C<light>', 'C<zero>' ); output '=item terminal_size = 80x24'; output $self->loc( q{Initial size of terminals to use. NOTE: the number of lines (24) will be decreased when resizing terminals for tiling, not the number of characters (80).} ); output '=item terminal_title_opt = -T'; output $self->loc( q{Option used with [_1] to set the title of the window}, 'C<terminal>' ); output q{=item terminal_allow_send_events = -xrm '*.VT100.allowSendEvents:true'}; output $self->loc( q{Option required by the terminal to allow XSendEvents to be received} ); output '=item title = cssh'; output $self->loc( q{Title of windows to use for both the console and terminals.}); output '=item unmap_on_redraw = no'; output $self->loc( q{Tell Tk to use the UnmapWindow request before redrawing terminal windows. This defaults to "no" as it causes some problems with the FVWM window manager. If you are experiencing problems with redraws, you can set it to "yes" to allow the window to be unmapped before it is repositioned.} ); output '=item use_all_a_records = 0'; output $self->loc( q{If a hostname resolves to multiple IP addresses, set to [_1] to connect to all of them, not just the first one found. See also [_2]}, 'C<1>', 'C<--use-all-a-records>}' ); output '=item use_hotkeys = 1'; output $self->loc( q{Setting to [_1] will disable all hotkeys.}, 'C<0>' ); output '=item use_natural_sort = 0'; output $self->loc( q{Windows will normally sort in alphabetical order, i.e.: host1, host11, host2. Setting to this [_1] will change the sort order, i.e.: host1, host2, host11. NOTE: You must have the perl module [_2] installed.}, 'C<1>', 'L<Sort::Naturally>' ); output '=item user = $LOGNAME'; output $self->loc( q{Sets the default user for running commands on clients.}); output '=item window_tiling = 1'; output $self->loc( q{Perform window tiling (set to [_1] to disable)}, 'C<0>' ); output '=item window_tiling_direction = right'; output $self->loc( q{Direction to tile windows, where [_1] means starting top left and moving right and then down, and anything else means starting bottom right and moving left and then up}, 'C<right>' ); output '=back'; output $self->loc( q{B<NOTE:> The key shortcut modifiers must be in the form [_1], [_2] or [_3], e.g. with the first letter capitalised and the rest lower case. Keys may also be disabled individually by setting to the word [_4].}, 'C<Control>', 'C<Alt>', 'C<Shift>', 'C<null>' ); output q{=item F<$HOME/.clusterssh/send_menu>}; output $self->loc( q{This (optional) file contains items to populate the send menu. The default entry could be written as:} ); output ' <send_menu> <menu title="Use Macros"> <toggle/> <accelerator>ALT-p</accelerator> </menu> <menu title="Remote Hostname"> <command>%s</command> <accelerator>ALT-n</accelerator> </menu> <menu title="Local Hostname"> <command>%s</command> <accelerator>ALT-l</accelerator> </menu> <menu title="Username"> <command>%u</command> <accelerator>ALT-u</accelerator> </menu> <menu title="Test Text"> <command>echo "ClusterSSH Version: %v%n</command> </menu> </send_menu>'; output $self->loc(q{Submenus can also be specified as follows:}); output ' <send_menu> <menu title="Default Entries"> <detach>yes</detach> <menu title="Hostname"> <command>%s</command> <accelerator>ALT-n</accelerator> </menu> </menu> </send_menu>'; output $self->loc(q{B<Caveats:>}); output '=over'; output '=item ', $self->loc( q{There is currently no strict format checking of this file.}); output '=item ', $self->loc(q{The format of the file may change in the future}); output '=item ', $self->loc( q{If the file exists, the default entry (Hostname) is not added}); output '=back'; output $self->loc( q{The following replacement macros are available (note: these can be changed in the configuration file):} ); output '=over'; output '=item %s'; output $self->loc( q{Hostname part of the specific connection string to each client, minus any username or port} ); output '=item %u'; output $self->loc( q{Username part of the connection string to each client}); output '=item %h'; output $self->loc(q{Hostname of server where cssh is being run from}); output '=item %n'; output $self->loc(q{C<RETURN> code}); output '=back'; output $self->loc( q{B<NOTE:> requires [_1] to be installed}, 'L<XML::Simple>' ); output '=back'; output '=head1 ', $self->loc('KNOWN BUGS'); output $self->loc( q{If you have any ideas about how to fix the below bugs, please get in touch and/or provide a patch.} ); output '=over'; output '=item *'; output $self->loc( q{Swapping virtual desktops can cause a redraw of all the terminal windows. This is due to a lack of distinction within Tk between switching desktops and minimising/maximising windows. Until Tk can tell the difference between the two events, there is no fix (apart from rewriting everything directly in X).} ); output '=back'; output '=head1 ', $self->loc('REPORTING BUGS'); output '=over'; output '=item *'; output $self->loc( q{If you have issues running [_1], first try: [_2] This performs two tests to confirm cssh is able to work properly with the settings provided within the [_3] file (or internal defaults). }, $Script, 'C<< ' . $Script . ' -e [user@]<hostname>[:port] >>', 'F<$HOME/.clusterssh/config>' ); output '=over'; output '=item 1'; output $self->loc( q{Test the terminal window works with the options provided}); output '=item 2'; output $self->loc( q{Test [_1] works to a host with the configured arguments}, $self->parent->config->{comms} ); output '=back'; output $self->loc(q{Configuration options to watch for in ssh are}); output '=over'; output '=item ', $self->loc( q{SSH doesn't understand [_1] - remove the option from the [_2] file}, 'C<-o ConnectTimeout=10>', 'F<$HOME/.clusterssh/config>' ); output '=item ', $self->loc( q{OpenSSH-3.8 using untrusted ssh tunnels - use [_1] instead of [_2] or use [_3] in [_4] (if you change the default ssh options from [_5] to [_6])}, 'C<-Y>', 'C<-X>', 'C<ForwardX11Trusted yes>', 'F<$HOME/.ssh/ssh_config>', 'C<-x>', 'C<-X>' ); output '=back'; output '=item *'; output $self->loc( q{If you require support, please run the following commands and post it on the web site in the support/problems forum:} ); output 'C<< perl -V >>'; output q{C<< perl -MTk -e 'print $Tk::VERSION,$/' >>}; output q{C<< perl -MX11::Protocol -e 'print $X11::Protocol::VERSION,$/' >>}; output 'C<< cat /etc/csshrc $HOME/.clusterssh/config >>'; output '=item *'; output $self->loc( q{Using the debug option (--debug) will turn on debugging output. Repeat the option to increase the amount of debug. However, if possible please only use this option with one host at a time, e.g. [_1] due to the amount of output produced (in both main and child windows).}, 'C<< cssh --debug <host> >>' ); output '=back'; output '=head1 ', $self->loc('SEE ALSO'); output $self->loc( q{L<http://clusterssh.sourceforge.net/>, C<ssh>, L<Tk::overview>, L<X11::Protocol>, C<perl>} ); output '=head1 ', $self->loc('CREDITS'); output $self->loc( 'A web site for comments, requests, bug reports and bug fixes/patches is available at: [_1]', 'L<https://github.com/duncs/clusterssh>' ); output '=head1 ', $self->loc('AUTHOR'); output 'Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >>'; output '=head1 ', $self->loc('LICENSE AND COPYRIGHT'); output $self->loc( q{ Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. } ); return $self; } 1; __DATA__ =pod =head1 NAME App::ClusterSSH::Getopt - module to process command line args =head1 SYNOPSIS =head1 DESCRIPTION Object representing application configuration =head1 METHODS =over 4 =item $obj=ClusterSSH::Getopts->new ({ }) Create a new object. =item $obj=ClusterSSH::Getopts->add_option ({ }) Add extra options into the allowed set for parsing from the command line =item $obj=ClusterSSH::Getopts->add_common_options ({ }) Add common options used by most calling scripts into the allowed set for parsing from the command line =item $obj=ClusterSSH::Getopts->add_common_session_options ({ }) Add common session options used by most calling scripts into the allowed set for parsing from the command line =item $obj=ClusterSSH::Getopts->add_common_ssh_options ({ }) Add common ssh options used by most calling scripts into the allowed set for parsing from the command line =item $obj->getopts Function to call after all options have been set up; creates methods to call for each option on the object, such as $obj->action, or $obj->username =item output(@) Simple helper func to print out pod lines with double returns =item help =item usage Functions to output help and usage instructions =back =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/Cluster.pm���������������������������������������������������000444��001750��001750�� 15506�12626321255� 22766� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Cluster; use strict; use warnings; use version; our $VERSION = version->new('0.01'); use Carp; use Try::Tiny; use English qw( -no_match_vars ); use base qw/ App::ClusterSSH::Base /; our $master_object_ref; sub new { my ( $class, %args ) = @_; if ( !$master_object_ref ) { $master_object_ref = $class->SUPER::new(%args); } return $master_object_ref; } sub get_cluster_entries { my ( $self, @files ) = @_; for my $file ( '/etc/clusters', $ENV{HOME} . '/.clusterssh/clusters', @files ) { $self->debug( 3, 'Loading in clusters from: ', $file ); $self->read_cluster_file($file); } return $self; } sub get_tag_entries { my ( $self, @files ) = @_; for my $file ( '/etc/tags', $ENV{HOME} . '/.clusterssh/tags', @files ) { $self->debug( 3, 'Loading in tags from: ', $file ); $self->read_tag_file($file); } return $self; } sub list_external_clusters { my ( $self, ) = @_; my @list = $self->_run_external_clusters('-L'); return wantarray ? sort @list : scalar @list; } sub get_external_clusters { my ( $self, @tags ) = @_; return $self->_run_external_clusters(@tags); } sub _run_external_clusters { my ( $self, @args ) = @_; my $external_command = $self->parent->config->{external_cluster_command}; if ( !$external_command || !-x $external_command ) { $self->debug( 1, 'Cannot run external cluster command: ', $external_command || '' ); return; } $self->debug( 3, 'Running tags through external command' ); $self->debug( 4, 'External command: ', $external_command ); $self->debug( 3, 'Args ', join( ',', @args ) ); my $command = "$external_command @args"; $self->debug( 3, 'Running ', $command ); my $result; my $return_code; { local $SIG{CHLD} = undef; $result = qx/ $command /; $return_code = $CHILD_ERROR >> 8; } chomp($result); $self->debug( 3, "Result: $result" ); $self->debug( 3, "Return code: $return_code" ); if ( $return_code != 0 ) { croak( App::ClusterSSH::Exception::Cluster->throw( error => $self->loc( "External command failure.\nCommand: [_1]\nReturn Code: [_2]", $command, $return_code, ), ) ); } my @results = split / /, $result; return @results; } sub read_tag_file { my ( $self, $filename ) = @_; $self->debug( 2, 'Reading tags from file ', $filename ); if ( -f $filename ) { my %hosts = $self->load_file( type => 'cluster', filename => $filename ); foreach my $host ( keys %hosts ) { $self->debug( 4, "Got entry for $host on tags $hosts{$host}" ); $self->register_host( $host, split( /\s+/, $hosts{$host} ) ); } } else { $self->debug( 2, 'No file found to read' ); } return $self; } sub read_cluster_file { my ( $self, $filename ) = @_; $self->debug( 2, 'Reading clusters from file ', $filename ); if ( -f $filename ) { my %tags = $self->load_file( type => 'cluster', filename => $filename ); foreach my $tag ( keys %tags ) { $self->register_tag( $tag, split( /\s+/, $tags{$tag} ) ); } } else { $self->debug( 2, 'No file found to read' ); } return $self; } sub register_host { my ( $self, $node, @tags ) = @_; $self->debug( 2, "Registering node $node on tags:", join( ' ', @tags ) ); foreach my $tag (@tags) { if ( $self->{tags}->{$tag} ) { $self->{tags}->{$tag} = [ sort @{ $self->{tags}->{$tag} }, $node ]; } else { $self->{tags}->{$tag} = [$node]; } #push(@{ $self->{tags}->{$tag} }, $node); } return $self; } sub register_tag { my ( $self, $tag, @nodes ) = @_; $self->debug( 2, "Registering tag $tag: ", join( ' ', @nodes ) ); $self->{tags}->{$tag} = \@nodes; return $self; } sub get_tag { my ( $self, $tag ) = @_; if ( $self->{tags}->{$tag} ) { $self->debug( 2, "Retrieving tag $tag: ", join( ' ', sort @{ $self->{tags}->{$tag} } ) ); return wantarray ? sort @{ $self->{tags}->{$tag} } : scalar @{ $self->{tags}->{$tag} }; } $self->debug( 2, "Tag $tag is not registered" ); return; } sub list_tags { my ($self) = @_; return wantarray ? sort keys( %{ $self->{tags} } ) : scalar keys( %{ $self->{tags} } ); } sub dump_tags { my ($self) = @_; return %{ $self->{tags} }; } #use overload ( # q{""} => sub { # my ($self) = @_; # return $self->{hostname}; # }, # fallback => 1, #); 1; =pod =head1 NAME App::ClusterSSH::Cluster - Object representing cluster configuration =head1 SYNOPSIS =head1 DESCRIPTION Object representing application configuration =head1 METHODS =over 4 =item $cluster=ClusterSSH::Cluster->new(); Create a new object. Object should be common across all invocations. =item $cluster->get_cluster_entries($filename); Read in /etc/clusters, $HOME/.clusterssh/clusters and any other given file name and register the tags found. =item @external_tags=list_external_clusters() Call an external script suing C<-L> to list available tags =item @resolved_tags=get_external_clusters(@tags) Use an external script to resolve C<@tags> into hostnames. =item $cluster->get_tag_entries($filename); Read in /etc/tags, $HOME/.clusterssh/tags and any other given file name and register the tags found. =item $cluster->read_cluster_file($filename); Read in the given cluster file and register the tags found =item $cluster->read_tag_file($filename); Read in the given tag file and register the tags found =item $cluster->register_tag($tag,@hosts); Register the given tag name with the given host names. =item $cluster->register_host($host,@tags); Register the given host on the provided tags. =item @entries = $cluster->get_tag('tag'); =item $entries = $cluster->get_tag('tag'); Retrieve all entries for the given tag. Returns an array of hosts or the number of hosts in the array depending on context. =item @tags = $cluster->list_tags(); Return an array of all available tag names =item %tags = $cluster->dump_tags(); Returns a hash of all tag data. =back =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/L10N.pm������������������������������������������������������000444��001750��001750�� 2141�12626321255� 21766� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::L10N; use strict; use warnings; use Locale::Maketext 1.01; use base qw(Locale::Maketext); # This projects primary language is English our %Lexicon = ( '_AUTO' => 1, ); 1; =pod =head1 NAME ClusterSSH::L10N - Base translations module =head1 SYNOPSIS use ClusterSSH::L10N; my $lang = ClusterSSH::L10N->get_handle('en'); $lang->maketext('text to localise with args [_1]', $arg1); =head1 DESCRIPTION L<Locale::Maketext> based translation module for ClusterSSH. See L<Locale::Maketext> for more information and usage. NOTE: the default language of this module is English. =head1 METHODS See Locale::Maketext - there are curently no extra methods in this module. =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/L10N���������������������������������������������������������000755��001750��001750�� 0�12626321255� 21275� 5����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/lib/App/ClusterSSH/L10N/en.pm���������������������������������������������������000444��001750��001750�� 1706�12626321255� 22376� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::L10N::en; use base 'App::ClusterSSH::L10N'; %Lexicon = ( '_AUTO' => 1, ); 1; =pod =head1 NAME App::ClusterSSH::L10N::en - Base English translations module =head1 SYNOPSIS use App::ClusterSSH::L10N; my $lang = ClusterSSH::L10N->get_handle('en'); $lang->maketext('text to localise with args [_1]', $arg1); =head1 DESCRIPTION L<Locale::Maketext> based translation module for ClusterSSH. See L<Locale::Maketext> for more information and usage. =head1 METHODS No method are exported. See L<Locale::Maketext>. =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2015 Duncan Ferguson. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; ����������������������������������������������������������App-ClusterSSH-4.05/t�������������������������������������������������������������������������������000755��001750��001750�� 0�12626321255� 15601� 5����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/30cluster.file3���������������������������������������������������������������000444��001750��001750�� 153�12626321255� 20465� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# a comment tag1 host1 tag2 host2 #line wrapped tag3 host3 \ host4 default host7 host8 host9 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/15config.t.file1��������������������������������������������������������������000444��001750��001750�� 213�12626321255� 20511� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������screen_reserve_top = 100 screen_reserve_bottom = 160 screen_reserve_left = 100 screen_reserve_right = 100 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/perltidyrc��������������������������������������������������������������������000444��001750��001750�� 166�12626321255� 20025� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# perltidy to Perl Best Practices standard -pbp -nst -nse ## For use in ~/.perltidyrc # --backup-and-modify-in-place ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/00-load.t���������������������������������������������������������������������000444��001750��001750�� 277�12626321255� 17245� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use FindBin; use lib $FindBin::Bin. '/../lib'; use Test::More tests => 1; BEGIN { use_ok('App::ClusterSSH'); } note("Testing App::ClusterSSH $App::ClusterSSH::VERSION, Perl $], $^X"); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/pod-coverage.t����������������������������������������������������������������000444��001750��001750�� 1053�12626321255� 20475� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/changes.t���������������������������������������������������������������������000444��001750��001750�� 203�12626321255� 17506� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/pod.t�������������������������������������������������������������������������000444��001750��001750�� 350�12626321255� 16663� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/boilerplate.t�����������������������������������������������������������������000444��001750��001750�� 2370�12626321255� 20427� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!perl -T use strict; use warnings; use Test::More tests => 3; sub not_in_file_ok { my ( $filename, %regex ) = @_; open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!"; my %violated; while ( my $line = <$fh> ) { while ( my ( $desc, $regex ) = each %regex ) { if ( $line =~ $regex ) { push @{ $violated{$desc} ||= [] }, $.; } } } if (%violated) { fail("$filename contains boilerplate text"); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass("$filename contains no boilerplate text"); } } sub module_boilerplate_ok { my ($module) = @_; not_in_file_ok( $module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } TODO: { not_in_file_ok( README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok( Changes => "placeholder date/time" => qr(Date/time) ); module_boilerplate_ok('lib/App/ClusterSSH.pm'); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/30cluster.tag1����������������������������������������������������������������000444��001750��001750�� 262�12626321255� 20320� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������host10 tag10 tag20 tag30 host20 tag10 # same host split over two lines host30 tag10 host20 tag40 # part two of earlier host host30 tag40 \ # multi line second part tag tag50 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/15config.t.file3��������������������������������������������������������������000444��001750��001750�� 2511�12626321255� 20536� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Configuration dump produced by 'cssh -u' auto_quit=yes clusters=duncs test fred duncs1 fred1 test1 test2 test3 test4 test5 live test dev kvm command= comms=ssh console_position= extra_cluster_file= history_height=10 history_width=40 key_addhost=Control-Shift-plus key_clientname=Alt-n key_history=Alt-h key_localname=Alt-l key_paste=Control-v key_quit=Control-q key_retilehosts=Alt-r key_username=Alt-n max_host_menu_items=30 method=ssh mouse_paste=Button-2 rsh_args= screen_reserve_bottom=60 screen_reserve_left=0 screen_reserve_right=0 screen_reserve_top=0 show_history=0 ssh=/usr/bin/ssh ssh_args= -x -o ConnectTimeout=10 telnet_args= terminal=/usr/bin/xterm terminal_allow_send_events=-xrm '*.VT100.allowSendEvents:true' terminal_args= terminal_bg_style=dark terminal_colorize=1 terminal_decoration_height=10 terminal_decoration_width=8 terminal_font=6x13 terminal_reserve_bottom=0 terminal_reserve_left=5 terminal_reserve_right=0 terminal_reserve_top=5 terminal_size=80x24 terminal_title_opt=-T title=CSSH unmap_on_redraw=no use_hotkeys=yes window_tiling=yes window_tiling_direction=right duncs=orion test=macbook fred=duncs test duncs1=orion test1=macbook fred1=duncs test test2=macbook test3=macbook test4=macbook test5=macbook live = live1 live2 live3 \ live4 live 5 live 6 test=test1 test2 test3 test4 dev=dev1 dev2 dev3 dev4 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/15config.t.file2��������������������������������������������������������������000444��001750��001750�� 32�12626321255� 20471� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������missing=what rubbish=here ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/10host.t����������������������������������������������������������������������000444��001750��001750�� 61651�12626321255� 17272� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Force use of English in tests for the moment, for those users that # have a different locale set, since errors are hardcoded below use POSIX qw(setlocale locale_h); setlocale( LC_ALL, "C" ); use FindBin qw($Bin); use lib "$Bin/../lib"; use Test::More; use Test::Trap; BEGIN { use_ok("App::ClusterSSH::Host") } my $host; eval { $host = App::ClusterSSH::Host->new(); }; isa_ok( $@, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); like( $@, qr/hostname is undefined/, 'eval error - hostname is undefined (method)' ); #============= # NOTE: #============= # 'Eevo5ang' is a randomly generated hostname used in these tests # as one user actually had a host called 'hostname' on their network # 'Ooquiida.com' is also a randomly generated domain name diag('Checking IPv4 type addresses') if ( $ENV{TEST_VERBOSE} ); $host = App::ClusterSSH::Host->new( hostname => 'Eevo5ang' ); is( $host, 'Eevo5ang', 'stringify works' ); is( $host->get_hostname, 'Eevo5ang', 'hostname set' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); is( $host->get_master, q{}, 'master set' ); is( $host->get_type, q{}, 'type set' ); $host->set_port(2323); is( $host, 'Eevo5ang', 'stringify works' ); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); is( $host->get_master, q{}, 'master set' ); is( $host->get_type, q{}, 'type set' ); $host->set_username('username'); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); is( $host->get_master, q{}, 'master set' ); is( $host->get_type, q{}, 'type set' ); $host->set_geometry('100x50+100+100'); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, '100x50+100+100', 'geometry set' ); is( $host->get_master, q{}, 'master set' ); is( $host->get_type, q{}, 'type set' ); $host->set_master('some_host'); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, '100x50+100+100', 'geometry set' ); is( $host->get_master, 'some_host', 'master set' ); is( $host->get_type, q{}, 'type set' ); $host->set_type('something'); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, '100x50+100+100', 'geometry set' ); is( $host->get_master, 'some_host', 'master set' ); is( $host->get_type, 'something', 'type set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'Eevo5ang', port => 2323, ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'Eevo5ang', 'stringify works' ); is( $host->get_hostname, 'Eevo5ang', 'hostname set' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); $host->set_username('username'); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'Eevo5ang', username => 'username', ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'Eevo5ang', 'stringify works' ); is( $host->get_hostname, 'Eevo5ang', 'hostname set' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); $host->set_port(2323); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'Eevo5ang', username => 'username', port => 2323, ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'Eevo5ang', 'stringify works' ); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'Eevo5ang', username => 'username', port => 2323, geometry => '100x50+100+100', ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'Eevo5ang', 'stringify works' ); is( $host->get_hostname, 'Eevo5ang', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'Eevo5ang', 'realname set' ); is( $host->get_geometry, '100x50+100+100', 'geometry set' ); diag('Parsing tests') if ( $ENV{TEST_VERBOSE} ); my %parse_tests = ( 'Eevo5ang' => { hostname => 'Eevo5ang', port => q{}, username => q{}, realname => 'Eevo5ang', geometry => q{}, type => 'ipv4', }, 'Eevo5ang.Ooquiida.com' => { hostname => 'Eevo5ang.Ooquiida.com', port => q{}, username => q{}, realname => 'Eevo5ang.Ooquiida.com', geometry => q{}, type => 'ipv4', }, 'Eevo5ang:2323' => { hostname => 'Eevo5ang', port => 2323, username => q{}, realname => 'Eevo5ang', geometry => q{}, type => 'ipv4', }, 'Eevo5ang:3232=1x1+1+1' => { hostname => 'Eevo5ang', port => 3232, username => q{}, realname => 'Eevo5ang', geometry => '1x1+1+1', type => 'ipv4', }, 'Eevo5ang.Ooquiida.com:3232' => { hostname => 'Eevo5ang.Ooquiida.com', port => 3232, username => q{}, realname => 'Eevo5ang.Ooquiida.com', geometry => q{}, type => 'ipv4', }, 'Eevo5ang.Ooquiida.com:3232=1x1+1+1' => { hostname => 'Eevo5ang.Ooquiida.com', port => 3232, username => q{}, realname => 'Eevo5ang.Ooquiida.com', geometry => '1x1+1+1', type => 'ipv4', }, 'user@Eevo5ang' => { hostname => 'Eevo5ang', port => q{}, username => 'user', realname => 'Eevo5ang', geometry => q{}, type => 'ipv4', }, 'user@Eevo5ang.Ooquiida.com' => { hostname => 'Eevo5ang.Ooquiida.com', port => q{}, username => 'user', realname => 'Eevo5ang.Ooquiida.com', geometry => q{}, type => 'ipv4', }, 'user@Eevo5ang:2323' => { hostname => 'Eevo5ang', port => 2323, username => 'user', realname => 'Eevo5ang', geometry => q{}, type => 'ipv4', }, 'user@Eevo5ang:3232=1x1+1+1' => { hostname => 'Eevo5ang', port => 3232, username => 'user', realname => 'Eevo5ang', geometry => '1x1+1+1', type => 'ipv4', }, 'user@Eevo5ang.Ooquiida.com:3232' => { hostname => 'Eevo5ang.Ooquiida.com', port => 3232, username => 'user', realname => 'Eevo5ang.Ooquiida.com', geometry => q{}, type => 'ipv4', }, 'user@Eevo5ang.Ooquiida.com:3232=1x1+1+1' => { hostname => 'Eevo5ang.Ooquiida.com', port => 3232, username => 'user', realname => 'Eevo5ang.Ooquiida.com', geometry => '1x1+1+1', type => 'ipv4', }, '127.0.0.1' => { hostname => '127.0.0.1', port => q{}, username => q{}, realname => '127.0.0.1', geometry => q{}, type => 'ipv4', }, '127.0.0.1:2323' => { hostname => '127.0.0.1', port => 2323, username => q{}, realname => '127.0.0.1', geometry => q{}, type => 'ipv4', }, '127.0.0.1:3232=1x1+1+1' => { hostname => '127.0.0.1', port => 3232, username => q{}, realname => '127.0.0.1', geometry => '1x1+1+1', type => 'ipv4', }, 'user@127.0.0.1' => { hostname => '127.0.0.1', port => q{}, username => 'user', realname => '127.0.0.1', geometry => q{}, type => 'ipv4', }, 'user@127.0.0.1:2323' => { hostname => '127.0.0.1', port => 2323, username => 'user', realname => '127.0.0.1', geometry => q{}, type => 'ipv4', }, 'user@127.0.0.1=2x2+2+2' => { hostname => '127.0.0.1', port => q{}, username => 'user', realname => '127.0.0.1', geometry => '2x2+2+2', type => 'ipv4', }, 'user@127.0.0.1:3232=1x1+1+1' => { hostname => '127.0.0.1', port => 3232, username => 'user', realname => '127.0.0.1', geometry => '1x1+1+1', type => 'ipv4', }, '::1' => { hostname => '::1', port => q{}, username => q{}, realname => '::1', geometry => q{}, type => 'ipv6', }, '::1:2323' => { hostname => '::1:2323', port => q{}, username => q{}, realname => '::1:2323', geometry => q{}, type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, '::1/2323' => { hostname => '::1', port => 2323, username => q{}, realname => '::1', geometry => q{}, type => 'ipv6', }, '::1:2323=3x3+3+3' => { hostname => '::1:2323', port => q{}, username => q{}, realname => '::1:2323', geometry => '3x3+3+3', type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, '::1/2323=3x3+3+3' => { hostname => '::1', port => 2323, username => q{}, realname => '::1', geometry => '3x3+3+3', type => 'ipv6', }, 'user@::1' => { hostname => '::1', port => q{}, username => 'user', realname => '::1', geometry => q{}, type => 'ipv6', }, 'user@::1:4242' => { hostname => '::1:4242', port => q{}, username => 'user', realname => '::1:4242', geometry => q{}, type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, 'user@::1/4242' => { hostname => '::1', port => 4242, username => 'user', realname => '::1', geometry => q{}, type => 'ipv6', }, 'user@::1=5x5+5+5' => { hostname => '::1', port => q{}, username => 'user', realname => '::1', geometry => '5x5+5+5', type => 'ipv6', }, 'user@::1:4242=5x5+5+5' => { hostname => '::1:4242', port => q{}, username => 'user', realname => '::1:4242', geometry => '5x5+5+5', type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, 'user@::1/4242=5x5+5+5' => { hostname => '::1', port => 4242, username => 'user', realname => '::1', geometry => '5x5+5+5', type => 'ipv6', }, '[::1]' => { hostname => '::1', port => q{}, username => q{}, realname => '::1', geometry => q{}, type => 'ipv6', }, '[::1]:2323' => { hostname => '::1', port => 2323, username => q{}, realname => '::1', geometry => q{}, type => 'ipv6', }, '[::1]:2323=3x3+3+3' => { hostname => '::1', port => 2323, username => q{}, realname => '::1', geometry => '3x3+3+3', type => 'ipv6', }, 'user@[::1]' => { hostname => '::1', port => q{}, username => 'user', realname => '::1', geometry => q{}, type => 'ipv6', }, 'user@[::1]:4242' => { hostname => '::1', port => 4242, username => 'user', realname => '::1', geometry => q{}, type => 'ipv6', }, 'user@[::1]=5x5+5+5' => { hostname => '::1', port => q{}, username => 'user', realname => '::1', geometry => '5x5+5+5', type => 'ipv6', }, 'user@[::1]:4242=5x5+5+5' => { hostname => '::1', port => 4242, username => 'user', realname => '::1', geometry => '5x5+5+5', type => 'ipv6', }, '2001:0db8:85a3:0000:0000:8a2e:0370:7334' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, 'jo@2001:0db8:85a3:0000:0000:8a2e:0370:7334' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => 'jo', realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, '2001:0db8:85a3:0000:0000:8a2e:0370:7334=9x9+9+9' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => '9x9+9+9', type => 'ipv6', }, 'jo@2001:0db8:85a3:0000:0000:8a2e:0370:7334=8x8+8+8' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => 'jo', realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => '8x8+8+8', type => 'ipv6', }, '2001:0db8:85a3:0000:0000:8a2e:0370:7334:22' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => 22, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, '2001:0db8:85a3:0000:0000:8a2e:0370:7334/22' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => 22, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, '[2001:0db8:85a3:0000:0000:8a2e:0370:7334]' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, 'jo@[2001:0db8:85a3:0000:0000:8a2e:0370:7334]' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => 'jo', realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, '[2001:0db8:85a3:0000:0000:8a2e:0370:7334]=9x9+9+9' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => '9x9+9+9', type => 'ipv6', }, 'jo@[2001:0db8:85a3:0000:0000:8a2e:0370:7334]=8x8+8+8' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => q{}, username => 'jo', realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => '8x8+8+8', type => 'ipv6', }, '[2001:0db8:85a3:0000:0000:8a2e:0370:7334]:22' => { hostname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', port => 22, username => q{}, realname => '2001:0db8:85a3:0000:0000:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, '2001:0db8:85a3::8a2e:0370:7334' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => q{}, type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, '2001:0db8:85a3::8a2e:0370/7334' => { hostname => '2001:0db8:85a3::8a2e:0370', port => 7334, username => q{}, realname => '2001:0db8:85a3::8a2e:0370', geometry => q{}, type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, 'pete@2001:0db8:85a3::8a2e:0370:7334' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => 'pete', realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => q{}, type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, 'pete@2001:0db8:85a3::8a2e:0370/7334' => { hostname => '2001:0db8:85a3::8a2e:0370', port => 7334, username => 'pete', realname => '2001:0db8:85a3::8a2e:0370', geometry => q{}, type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, 'pete@2001:0db8:85a3::8a2e:0370:7334=2x3+4+5' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => 'pete', realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => '2x3+4+5', type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, 'pete@2001:0db8:85a3::8a2e:0370/7334=2x3+4+5' => { hostname => '2001:0db8:85a3::8a2e:0370', port => 7334, username => 'pete', realname => '2001:0db8:85a3::8a2e:0370', geometry => '2x3+4+5', type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, '2001:0db8:85a3::8a2e:0370:7334=2x3+4+5' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => '2x3+4+5', type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, '2001:0db8:85a3::8a2e:0370/7334=2x3+4+5' => { hostname => '2001:0db8:85a3::8a2e:0370', port => 7334, username => q{}, realname => '2001:0db8:85a3::8a2e:0370', geometry => '2x3+4+5', type => 'ipv6', stderr => qr{Ambiguous host string:.*Assuming you meant}ms }, '[2001:0db8:85a3::8a2e:0370:7334]' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, 'pete@[2001:0db8:85a3::8a2e:0370:7334]' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => 'pete', realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, 'pete@[2001:0db8:85a3::8a2e:0370:7334]=2x3+4+5' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => 'pete', realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => '2x3+4+5', type => 'ipv6', }, '[2001:0db8:85a3::8a2e:0370:7334]=2x3+4+5' => { hostname => '2001:0db8:85a3::8a2e:0370:7334', port => q{}, username => q{}, realname => '2001:0db8:85a3::8a2e:0370:7334', geometry => '2x3+4+5', type => 'ipv6', }, 'pete@[2001:0db8:8a2e:0370:7334]' => { hostname => '2001:0db8:8a2e:0370:7334', port => q{}, username => 'pete', realname => '2001:0db8:8a2e:0370:7334', geometry => q{}, type => 'ipv6', }, '2001:0db8:8a2e:0370:7334:2001:0db8:8a2e:0370:7334:4535:3453:3453:3455' => { die => qr{Unable to parse hostname from}ms, }, 'some random rubbish' => { die => qr{Unable to parse hostname from}ms, }, ); foreach my $ident ( keys(%parse_tests) ) { $host = undef; trap { $host = App::ClusterSSH::Host->parse_host_string($ident); }; if ( $parse_tests{$ident}{die} ) { is( $trap->leaveby, 'die', $ident . ' died correctly' ); like( $trap->die, $parse_tests{$ident}{die}, $ident . ' died correctly' ); next; } is( $trap->leaveby, 'return', $ident . ' returned correctly' ); is( $host, $parse_tests{$ident}{hostname}, 'stringify works on: ' . $ident ); isa_ok( $host, "App::ClusterSSH::Host" ); for my $trap_type (qw/ die /) { if ( !$parse_tests{$ident}{$trap_type} ) { is( $trap->$trap_type, $parse_tests{$ident}{$trap_type}, "$ident $trap_type" ); } else { like( $trap->$trap_type, $parse_tests{$ident}{$trap_type}, "$ident $trap_type" ); } } for my $trap_empty (qw/ stdout stderr /) { like( $trap->$trap_empty, $parse_tests{$ident}{$trap_empty} || qr{^$}, "$ident $trap_empty" ); } for my $attr (qw/ hostname type port username realname geometry /) { my $method = "get_$attr"; is( $host->$method, $parse_tests{$ident}{$attr}, "$ident $attr: " . $host->$method ); } is( $host->check_ssh_hostname, 0, $ident . ' not from ssh' ); } # check for a non-existant file trap { $host = App::ClusterSSH::Host->new( hostname => 'ssh_test', ssh_config => $Bin . '/some_bad_filename', ); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'ssh_test', 'stringify works' ); is( $host->check_ssh_hostname, 0, 'check_ssh_hostname ok for ssh_test', ); trap { $host = App::ClusterSSH::Host->new( hostname => 'ssh_test', ssh_config => $Bin . '/10host_ssh_config', ); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'ssh_test', 'stringify works' ); is( $host->check_ssh_hostname, 0, 'check_ssh_hostname ok for ssh_test', ); is( $host->get_type, q{}, 'hostname type is correct for ssh_test', ); for my $hostname ( 'server1', 'server2', 'server3', 'server4', 'server-5', 'server5.domain.name', 'server-6.domain.name' ) { $host = undef; is( $host, undef, 'starting afresh for ssh hostname checks' ); trap { $host = App::ClusterSSH::Host->new( hostname => $hostname, ssh_config => $Bin . '/10host_ssh_config', ); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, $hostname, 'stringify works' ); is( $host->check_ssh_hostname, 1, 'check_ssh_hostname ok for ' . $hostname ); is( $host->get_realname, $hostname, 'realname set' ); is( $host->get_geometry, q{}, 'geometry set' ); is( $host->get_type, 'ssh_alias', 'geometry set' ); } done_testing(); ���������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/30cluster.cannot_read���������������������������������������������������������000444��001750��001750�� 27�12626321255� 21720� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#cannot read this file ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/01l10n.t����������������������������������������������������������������������000444��001750��001750�� 413�12626321255� 17014� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use FindBin qw($Bin); use lib "$Bin/../lib"; use Test::More tests => 2; use Test::Trap; BEGIN { use_ok( 'App::ClusterSSH::L10N', ) } my $handle; $handle = App::ClusterSSH::L10N->get_handle(); isa_ok( $handle, 'App::ClusterSSH::L10N' ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/perltidy.t��������������������������������������������������������������������000444��001750��001750�� 532�12626321255� 17737� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!perl use strict; use warnings; use Test::More; use FindBin qw($Bin); eval "use Test::PerlTidy"; plan skip_all => "Test::PerlTidy required for testing code" if $@; # Please see t/perltidyrc for the authors normal perltidy options run_tests( perltidyrc => $Bin . '/perltidyrc', exclude => [ '_build/', 'blib/', 'Makefile.PL', ] ); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/15config.t��������������������������������������������������������������������000444��001750��001750�� 45731�12626321255� 17570� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Force use of English in tests for the moment, for those users that # have a different locale set, since errors are hardcoded below use POSIX qw(setlocale locale_h); setlocale( LC_ALL, "C" ); use FindBin qw($Bin $Script); use lib "$Bin/../lib"; use Test::More; use Test::Trap; use File::Which qw(which); use File::Temp qw(tempdir); use Test::Differences; use Readonly; BEGIN { use_ok("App::ClusterSSH::Config") || BAIL_OUT('failed to use module'); } my $config; $config = App::ClusterSSH::Config->new(); isa_ok( $config, 'App::ClusterSSH::Config' ); Readonly::Hash my %default_config => { terminal => "xterm", terminal_args => "", terminal_title_opt => "-T", terminal_colorize => 1, terminal_bg_style => 'dark', terminal_allow_send_events => "-xrm '*.VT100.allowSendEvents:true'", terminal_font => "6x13", terminal_size => "80x24", use_hotkeys => "yes", key_quit => "Alt-q", key_addhost => "Control-Shift-plus", key_clientname => "Alt-n", key_history => "Alt-h", key_localname => "Alt-l", key_retilehosts => "Alt-r", key_macros_enable => "Alt-p", key_paste => "Control-v", key_username => "Alt-u", mouse_paste => "Button-2", auto_quit => "yes", auto_close => 5, window_tiling => "yes", window_tiling_direction => "right", console_position => "", screen_reserve_top => 0, screen_reserve_bottom => 60, screen_reserve_left => 0, screen_reserve_right => 0, terminal_reserve_top => 5, terminal_reserve_bottom => 0, terminal_reserve_left => 5, terminal_reserve_right => 0, terminal_decoration_height => 10, terminal_decoration_width => 8, ssh => '/usr/bin/ssh', console => 'console', console_args => '', rsh => 'rsh', rsh_args => "", telnet => 'telnet', telnet_args => "", ssh => 'ssh', ssh_args => "", sftp => 'sftp', sftp_args => "", extra_cluster_file => "", external_cluster_command => '', unmap_on_redraw => "no", show_history => 0, history_width => 40, history_height => 10, command => q{}, title => q{15CONFIG.T}, comms => q{ssh}, max_host_menu_items => 30, macros_enabled => 'yes', macro_servername => '%s', macro_hostname => '%h', macro_username => '%u', macro_newline => '%n', macro_version => '%v', max_addhost_menu_cluster_items => 6, menu_send_autotearoff => 0, menu_host_autotearoff => 0, use_all_a_records => 0, use_natural_sort => 0, send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu', # other bits inheritted from App::ClusterSSH::Base debug => 0, lang => 'en', user => '', }; my %expected = %default_config; is_deeply( $config, \%expected, 'default config is correct' ); $config = App::ClusterSSH::Config->new(); trap { $config = $config->validate_args( whoops => 'not there', doesnt_exist => 'whoops', ); }; isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); is( $trap->die, 'Unknown configuration parameters: doesnt_exist,whoops' . $/, 'got correct error message' ); is_deeply( $trap->die->unknown_config, [ 'doesnt_exist', 'whoops' ], 'Picked up unknown config array' ); isa_ok( $config, "App::ClusterSSH::Config" ); $expected{extra_cluster_file} = '/etc/filename'; $expected{rsh_args} = 'some args'; $expected{max_addhost_menu_cluster_items} = 120; trap { $config = $config->validate_args( extra_cluster_file => '/etc/filename', rsh_args => 'some args', max_addhost_menu_cluster_items => 120, ); }; is( $trap->die, undef, 'validated ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); is_deeply( $config, \%expected, 'default config is correct' ); $config = App::ClusterSSH::Config->new(); %expected = %default_config; my $file = "$Bin/$Script.doesntexist"; trap { $config = $config->parse_config_file( $file, ); }; isa_ok( $trap->die, 'App::ClusterSSH::Exception::LoadFile' ); is( $trap->die, "Unable to read file $file: No such file or directory" . $/, 'got correct error message' ); $file = "$Bin/$Script.file1"; note("using $file"); $config = App::ClusterSSH::Config->new(); %expected = %default_config; $expected{screen_reserve_left} = 100; $expected{screen_reserve_right} = 100; $expected{screen_reserve_top} = 100; $expected{screen_reserve_bottom} = 160; trap { $config = $config->parse_config_file( $file, ); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); $file = "$Bin/$Script.file2"; note("using $file"); $config = App::ClusterSSH::Config->new(); %expected = %default_config; trap { $config = $config->parse_config_file( $file, ); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); is( $trap->die, 'Unknown configuration parameters: missing,rubbish' . $/, 'die message correct' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); $file = "$Bin/$Script.file3"; note("using $file"); $config = App::ClusterSSH::Config->new(); %expected = %default_config; trap { $config = $config->parse_config_file( $file, ); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); note('find_binary tests'); my $path; $config = App::ClusterSSH::Config->new(); trap { $path = $config->find_binary(); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, 'argument not provided' . $/, 'die message correct' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); trap { $path = $config->find_binary('missing'); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, '"missing" binary not found - please amend $PATH or the cssh config file' . $/, 'die message correct' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); trap { $path = $config->find_binary('ls'); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); is( $path, 'ls', 'Found correct path to "ls"' ); # check for a binary already found my $newpath; trap { $newpath = $config->find_binary($path); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); is( $path, 'ls', 'Found correct path to "ls"' ); is( $path, $newpath, 'No change made from find_binary' ); # give false path to force another search trap { $newpath = $config->find_binary( '/does/not/exist/' . $path ); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is_deeply( $config, \%expected, 'amended config is correct' ); is( $path, 'ls', 'Found correct path to "ls"' ); is( $path, $newpath, 'No change made from find_binary' ); note('Checks on loading configs'); note('empty dir'); $ENV{HOME} = tempdir( CLEANUP => 1 ); $config = App::ClusterSSH::Config->new(); trap { $config->load_configs(); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, 'Created new configuration file within $HOME/.clusterssh/' . $/, 'Got correct STDERR output for .csshrc' ); #note(qx/ls -laR $ENV{HOME}/); ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); is_deeply( $config, \%expected, 'amended config is correct' ); $ENV{HOME} = undef; note('.csshrc warning'); $ENV{HOME} = tempdir( CLEANUP => 1 ); open( my $csshrc, '>', $ENV{HOME} . '/.csshrc' ); print $csshrc 'auto_quit = no', $/; close($csshrc); $expected{auto_quit} = 'no'; $config = App::ClusterSSH::Config->new(); trap { $config->load_configs(); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, 'Moved $HOME/.csshrc to $HOME/.csshrc.DISABLED' . $/ . 'Created new configuration file within $HOME/.clusterssh/' . $/, 'Got correct STDERR output for .csshrc' ); ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); is_deeply( $config, \%expected, 'amended config is correct' ); note('.csshrc warning and .clusterssh dir plus config'); # need to recreate .csshrc as it was just moved open( $csshrc, '>', $ENV{HOME} . '/.csshrc' ); print $csshrc 'auto_quit = no', $/; close($csshrc); $expected{auto_quit} = 'no'; open( $csshrc, '>', $ENV{HOME} . '/.clusterssh/config' ); print $csshrc 'window_tiling = no', $/; close($csshrc); $expected{window_tiling} = 'no'; $config = App::ClusterSSH::Config->new(); trap { $config->load_configs(); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, 'Moved $HOME/.csshrc to $HOME/.csshrc.DISABLED' . $/, 'Got correct STDERR output for .csshrc' ); ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); is_deeply( $config, \%expected, 'amended config is correct' ); note('no .csshrc warning and .clusterssh dir'); unlink( $ENV{HOME} . '/.csshrc' ); $expected{auto_quit} = 'yes'; $config = App::ClusterSSH::Config->new(); trap { $config->load_configs(); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); is_deeply( $config, \%expected, 'amended config is correct' ); note('no .csshrc warning, .clusterssh dir plus config + extra config'); open( $csshrc, '>', $ENV{HOME} . '/clusterssh.config' ); print $csshrc 'terminal_args = something', $/; close($csshrc); $expected{terminal_args} = 'something'; $config = App::ClusterSSH::Config->new(); trap { $config->load_configs( $ENV{HOME} . '/clusterssh.config' ); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); is_deeply( $config, \%expected, 'amended config is correct' ); note('no .csshrc warning, .clusterssh dir plus config + more extra configs'); open( $csshrc, '>', $ENV{HOME} . '/.clusterssh/config_ABC' ); print $csshrc 'ssh_args = something', $/; close($csshrc); $expected{ssh_args} = 'something'; $config = App::ClusterSSH::Config->new(); trap { $config->load_configs( $ENV{HOME} . '/clusterssh.config', 'ABC' ); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); ok( -d $ENV{HOME} . '/.clusterssh', '.clusterssh dir exists' ); ok( -f $ENV{HOME} . '/.clusterssh/config', '.clusterssh config file exists' ); is_deeply( $config, \%expected, 'amended config is correct' ); note('check .clusterssh file is an error'); $ENV{HOME} = tempdir( CLEANUP => 1 ); open( $csshrc, '>', $ENV{HOME} . '/.clusterssh' ); print $csshrc 'should_be_dir_not_file = PROBLEM', $/; close($csshrc); $config = App::ClusterSSH::Config->new(); trap { $config->write_user_config_file(); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, 'Unable to create directory $HOME/.clusterssh: File exists' . $/, 'die message correct' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); note('check failure to write default config is caught'); $ENV{HOME} = tempdir( CLEANUP => 1 ); mkdir( $ENV{HOME} . '/.clusterssh' ); mkdir( $ENV{HOME} . '/.clusterssh/config' ); $config = App::ClusterSSH::Config->new(); trap { $config->write_user_config_file(); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception::Config' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, 'Unable to write default $HOME/.clusterssh/config: Is a directory' . $/, 'die message correct' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); note('check .clusterssh errors via load_configs are not fatal'); $ENV{HOME} = tempdir( CLEANUP => 1 ); open( $csshrc, '>', $ENV{HOME} . '/.clusterssh' ); print $csshrc 'should_be_dir_not_file = PROBLEM', $/; close($csshrc); $config = App::ClusterSSH::Config->new(); trap { $config->load_configs(); }; is( $trap->leaveby, 'return', 'died ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{Unable to create directory $HOME/.clusterssh: File exists} . $/ . $/, 'Expecting no STDERR' ); SKIP: { skip "Test inappropriate when running as root", 5, $< == 0; note('move of .csshrc failure'); $ENV{HOME} = tempdir( CLEANUP => 1 ); open( $csshrc, '>', $ENV{HOME} . '/.csshrc' ); print $csshrc "Something", $/; close($csshrc); open( $csshrc, '>', $ENV{HOME} . '/.csshrc.DISABLED' ); print $csshrc "Something else", $/; close($csshrc); chmod( 0666, $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} ); $config = App::ClusterSSH::Config->new(); trap { $config->write_user_config_file(); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, q{Unable to create directory $HOME/.clusterssh: Permission denied} . $/, 'Expected die msg ' . $trap->stderr ); chmod( 0755, $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} ); } note('check failure to write default config is caught'); $ENV{HOME} = tempdir( CLEANUP => 1 ); mkdir( $ENV{HOME} . '/.clusterssh' ); mkdir( $ENV{HOME} . '/.clusterssh/config' ); $config = App::ClusterSSH::Config->new(); trap { $config->load_configs(); }; is( $trap->leaveby, 'return', 'returned ok' ); isa_ok( $config, "App::ClusterSSH::Config" ); isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{Unable to write default $HOME/.clusterssh/config: Is a directory} . $/ . $/, 'Expecting no STDERR' ); note('Checking dump'); $config = App::ClusterSSH::Config->new( send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu', ); trap { $config->dump(); }; my $expected = qq{# Configuration dump produced by "cssh -u" auto_close=5 auto_quit=yes console=console console_args= console_position= debug=0 external_cluster_command= extra_cluster_file= history_height=10 history_width=40 key_addhost=Control-Shift-plus key_clientname=Alt-n key_history=Alt-h key_localname=Alt-l key_macros_enable=Alt-p key_paste=Control-v key_quit=Alt-q key_retilehosts=Alt-r key_username=Alt-u lang=en macro_hostname=%h macro_newline=%n macro_servername=%s macro_username=%u macro_version=%v macros_enabled=yes max_addhost_menu_cluster_items=6 max_host_menu_items=30 menu_host_autotearoff=0 menu_send_autotearoff=0 mouse_paste=Button-2 rsh=rsh rsh_args= screen_reserve_bottom=60 screen_reserve_left=0 screen_reserve_right=0 screen_reserve_top=0 send_menu_xml_file=} . $ENV{HOME} . qq{/.clusterssh/send_menu sftp=sftp sftp_args= show_history=0 ssh=ssh ssh_args= telnet=telnet telnet_args= terminal=xterm terminal_allow_send_events=-xrm '*.VT100.allowSendEvents:true' terminal_args= terminal_bg_style=dark terminal_colorize=1 terminal_decoration_height=10 terminal_decoration_width=8 terminal_font=6x13 terminal_reserve_bottom=0 terminal_reserve_left=5 terminal_reserve_right=0 terminal_reserve_top=5 terminal_size=80x24 terminal_title_opt=-T unmap_on_redraw=no use_all_a_records=0 use_hotkeys=yes use_natural_sort=0 #user= window_tiling=yes window_tiling_direction=right }; isa_ok( $config, "App::ClusterSSH::Config" ); is( $trap->die, undef, 'die message correct' ); eq_or_diff( $trap->stdout, $expected, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); done_testing(); ���������������������������������������App-ClusterSSH-4.05/t/20helper.t��������������������������������������������������������������������000444��001750��001750�� 5663�12626321255� 17556� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Force use of English in tests for the moment, for those users that # have a different locale set, since errors are hardcoded below use POSIX qw(setlocale locale_h); setlocale( LC_ALL, "C" ); use FindBin qw($Bin $Script); use lib "$Bin/../lib"; use Test::More; use Test::Trap; use File::Which qw(which); use File::Temp qw(tempdir); use Readonly; package App::ClusterSSH::Config; sub new { my ( $class, %args ) = @_; my $self = {%args}; return bless $self, $class; } package main; BEGIN { use_ok("App::ClusterSSH::Helper") || BAIL_OUT('failed to use module'); } my $helper; $helper = App::ClusterSSH::Helper->new(); isa_ok( $helper, 'App::ClusterSSH::Helper' ); my $script; trap { $script = $helper->script; }; is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, 'No configuration provided or in wrong format', 'no config' ); trap { $script = $helper->script( something => 'nothing' ); }; is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, 'No configuration provided or in wrong format', 'bad format' ); my $mock_config = App::ClusterSSH::Config->new(); trap { $script = $helper->script($mock_config); }; is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); # ignore stderr here as it will complain about missing xxx_arg var #is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, q{Config 'comms' not provided}, 'missing arg' ); $mock_config->{comms} = 'method'; trap { $script = $helper->script($mock_config); }; is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, q{Config 'method' not provided}, 'missing arg' ); $mock_config->{method} = 'binary'; trap { $script = $helper->script($mock_config); }; is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, q{Config 'method_args' not provided}, 'missing arg' ); $mock_config->{method_args} = 'rubbish'; $mock_config->{command} = 'echo'; $mock_config->{auto_close} = 5; trap { $script = $helper->script($mock_config); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, undef, 'not died' ); trap { eval {$script}; }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->die, undef, 'not died' ); done_testing(); �����������������������������������������������������������������������������App-ClusterSSH-4.05/t/manifest.t��������������������������������������������������������������������000444��001750��001750�� 575�12626321255� 17720� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More; # This is the common idiom for author test modules like this, but see # the full example in examples/checkmanifest.t and, more importantly, # Adam Kennedy's article: http://use.perl.org/~Alias/journal/38822 eval 'use Test::DistManifest'; if ($@) { plan skip_all => 'Test::DistManifest required to test MANIFEST'; } manifest_ok( 'MANIFEST', 'MANIFEST.SKIP' ); �����������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/80clusterssh.t����������������������������������������������������������������000444��001750��001750�� 1033�12626321255� 20467� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Force use of English in tests for the moment, for those users that # have a different locale set, since errors are hardcoded below use POSIX qw(setlocale locale_h); setlocale( LC_ALL, "C" ); use FindBin qw($Bin $Script); use lib "$Bin/../lib"; use Test::More; use Test::Trap; use File::Which qw(which); use Readonly; BEGIN { use_ok("App::ClusterSSH") } my $app; $app = App::ClusterSSH->new(); isa_ok( $app, 'App::ClusterSSH' ); isa_ok( $app->config, 'App::ClusterSSH::Config' ); done_testing(); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/external_cluster_command������������������������������������������������������000555��001750��001750�� 1666�12626321255� 22756� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl # # test script for proving external command for fetching tags works # use strict; use warnings; use Getopt::Std; my $opt = {}; getopts( 'Lqx', $opt ); my %tag_lookup = ( tag100 => [qw/ host100 /], tag200 => [qw/ host200 host210 host205 /], tag300 => [qw/ host300 host350 host325 /], tag400 => [qw/ tag100 tag200 tag300 host400 host401 /], ); # if we get '-q' option, force an error if ( $opt->{q} ) { my $fail; $fail->cause_death(); } # if we get '-x' option, die with non-0 return code if ( $opt->{x} ) { warn 'Forced non-0 exit', $/; exit 5; } # '-L' means list out available tags if ( $opt->{L} ) { print join(' ', sort keys %tag_lookup), $/; exit 0; } my @lookup = @ARGV; for (@lookup) { if ( $tag_lookup{$_} ) { push( @lookup, @{ $tag_lookup{$_} } ); $_ = ''; } } @lookup = grep { $_ !~ m/^$/ } sort @lookup; if (@lookup) { print "@lookup", $/; } ��������������������������������������������������������������������������App-ClusterSSH-4.05/t/30cluster.t�������������������������������������������������������������������000444��001750��001750�� 20606�12626321255� 17773� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Force use of English in tests for the moment, for those users that # have a different locale set, since errors are hardcoded below use POSIX qw(setlocale locale_h); setlocale( LC_ALL, "C" ); use FindBin qw($Bin $Script); use lib "$Bin/../lib"; use Test::More; use Test::Trap; use File::Which qw(which); use File::Temp qw(tempdir); use English '-no_match_vars'; use Readonly; package Test::ClusterSSH::Mock; # generate purpose object used to simplfy testing sub new { my ( $class, %args ) = @_; my $config = {%args}; return bless $config, $class; } sub parent { my ($self) = @_; return $self; } sub config { my ($self) = @_; return $self; } sub load_configs { my ($self) = @_; return $self; } sub config_file { my ($self) = @_; return {}; } 1; package main; BEGIN { use_ok("App::ClusterSSH::Cluster") || BAIL_OUT('failed to use module'); } my $mock_object = Test::ClusterSSH::Mock->new(); my $cluster1 = App::ClusterSSH::Cluster->new( parent => $mock_object ); isa_ok( $cluster1, 'App::ClusterSSH::Cluster' ); my $cluster2 = App::ClusterSSH::Cluster->new(); isa_ok( $cluster2, 'App::ClusterSSH::Cluster' ); my %expected = ( people => [ 'fred', 'jo', 'pete', ] ); $cluster1->register_tag( 'people', @{ $expected{people} } ); my @got = $cluster2->get_tag('people'); is_deeply( \@got, \@{ $expected{people} }, 'Shared cluster object' ) or diag explain @got; my %got = $cluster2->dump_tags; is_deeply( \%got, \%expected, 'Shared cluster object' ) or diag explain %got; # should pass without issue trap { $cluster1->read_cluster_file( $Bin . '/30cluster.doesnt exist' ); }; is( !$trap, '', 'coped with missing file ok' ); isa_ok( $cluster1, 'App::ClusterSSH::Cluster' ); # no point running this test as root since root cannot be blocked # from accessing the file if ( $EUID != 0 ) { my $no_read = $Bin . '/30cluster.cannot_read'; chmod 0000, $no_read; trap { $cluster1->read_cluster_file($no_read); }; chmod 0644, $no_read; isa_ok( $trap->die, 'App::ClusterSSH::Exception::LoadFile' ); is( $trap->die, "Unable to read file $no_read: Permission denied", 'Error on reading an existing file ok' ); } else { pass('Cannot test for lack of read access when run as root'); } $expected{tag1} = ['host1']; $cluster1->read_cluster_file( $Bin . '/30cluster.file1' ); test_expected( 'file 1', %expected ); $expected{tag2} = [ 'host2', ]; $expected{tag3} = [ 'host3', 'host4' ]; $cluster1->read_cluster_file( $Bin . '/30cluster.file2' ); test_expected( 'file 2', %expected ); $expected{tag10} = [ 'host10', 'host20', 'host30' ]; $expected{tag20} = [ 'host10', ]; $expected{tag30} = [ 'host10', ]; $expected{tag40} = [ 'host20', 'host30', ]; $expected{tag50} = [ 'host30', ]; $cluster1->read_tag_file( $Bin . '/30cluster.tag1' ); test_expected( 'tag 1', %expected ); $cluster1->read_cluster_file( $Bin . '/30cluster.file3' ); my @default_expected = (qw/ host7 host8 host9 /); $expected{default} = \@default_expected; test_expected( 'file 3', %expected ); my @default = $cluster1->get_tag('default'); is_deeply( \@default, \@default_expected, 'default cluster ok' ); is( scalar $cluster1->get_tag('default'), scalar @default_expected, 'Count correct' ); my $tags; trap { $tags = $cluster1->get_tag('does_not_exist'); }; is( $trap->leaveby, 'return', 'non-existant tag returns correctly' ); is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); is( $tags, undef, 'non-existant tag returns undef' ); @default_expected = sort qw/ default people tag1 tag2 tag3 tag10 tag20 tag30 tag40 tag50 /; trap { @default = $cluster1->list_tags; }; is( $trap->leaveby, 'return', 'list_tags returned okay' ); is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); is_deeply( \@default, \@default_expected, 'tag list correct' ); my $count; trap { $count = $cluster1->list_tags; }; is( $trap->leaveby, 'return', 'list_tags returned okay' ); is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); is_deeply( $count, 10, 'tag list count correct' ); # now checks against running an external command my @external_expected; # text fetching external clusters when no command set or runnable #$mock_object->{external_cluster_command} = '/tmp/doesnt_exist'; trap { @external_expected = $cluster1->_run_external_clusters(); }; is( $trap->leaveby, 'return', 'non-existant tag returns correctly' ); is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); is( $tags, undef, 'non-existant tag returns undef' ); @external_expected = $cluster1->list_external_clusters(); is_deeply( \@external_expected, [], 'External command doesnt exist' ); is( scalar $cluster1->list_external_clusters, 0, 'External command failed tag count' ); $mock_object->{external_cluster_command} = "$Bin/external_cluster_command"; @external_expected = $cluster1->list_external_clusters(); is_deeply( \@external_expected, [qw/ tag100 tag200 tag300 tag400 /], 'External command no args' ); is( scalar $cluster1->list_external_clusters, 4, 'External command tag count' ); @external_expected = $cluster1->get_external_clusters(); is_deeply( \@external_expected, [], 'External command no args' ); @external_expected = $cluster1->get_external_clusters("tag1 tag2"); is_deeply( \@external_expected, [qw/tag1 tag2 /], 'External command: 2 args passed through' ); @external_expected = $cluster1->get_external_clusters("tag100"); is_deeply( \@external_expected, [qw/host100 /], 'External command: 1 tag expanded to one host' ); @external_expected = $cluster1->get_external_clusters("tag200"); is_deeply( \@external_expected, [qw/host200 host205 host210 /], 'External command: 1 tag expanded to 3 hosts and sorted' ); @external_expected = $cluster1->get_external_clusters("tag400"); is_deeply( \@external_expected, [ qw/host100 host200 host205 host210 host300 host325 host350 host400 host401 / ], 'External command: 1 tag expanded with self referencing tags' ); # NOTE # Since this is calling a shell run command, the tests cannot capture # the shell STDOUT and STDERR. By default redirect STDOUT and STDERR into # /dev/null so it dones't make noise in normal test output # However, don't hide it if running with -v flag my $redirect = ' 1>/dev/null 2>&1'; if ( $ENV{TEST_VERBOSE} ) { $redirect = ''; } trap { @external_expected = $cluster1->get_external_clusters("-x $redirect"); }; like( $trap->die, qr/External command failure.*external_cluster_command.*Return Code: 5/ms, 'External command: caught exception message' ); is( $trap->stdout, '', 'External command: no stdout from perl code' ); is( $trap->stderr, '', 'External command: no stderr from perl code' ); trap { @external_expected = $cluster1->get_external_clusters("-q $redirect"); }; like( $trap->die, qr/External command failure.*external_cluster_command.*Return Code: 255/ms, 'External command: caught exception message' ); is( $trap->stdout, '', 'External command: no stdout from perl code' ); is( $trap->stderr, '', 'External command: no stderr from perl code' ); # check reading of cluster files trap { $cluster1->get_cluster_entries( $Bin . '/30cluster.file3' ); }; is( $trap->leaveby, 'return', 'exit okay on get_cluster_entries' ); is( $trap->stdout, '', 'no stdout for get_cluster_entries' ); is( $trap->stderr, '', 'no stderr for get_cluster_entries' ); # check reading of tag files trap { $cluster1->get_tag_entries( $Bin . '/30cluster.tag1' ); }; is( $trap->leaveby, 'return', 'exit okay on get_tag_entries' ); is( $trap->stdout, '', 'no stdout for get_tag_entries' ); is( $trap->stderr, '', 'no stderr for get_tag_entries' ); done_testing(); sub test_expected { my ( $test, %expected ) = @_; foreach my $key ( keys %expected ) { my @got = $cluster2->get_tag($key); is_deeply( \@got, \@{ $expected{$key} }, 'file ' . $test . ' get_tag on: ' . $key ) or diag explain @got; } my %got = $cluster1->dump_tags; is_deeply( \%got, \%expected, 'file ' . $test . ' dump_tags' ) or diag explain %got; } ��������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/10host_ssh_config�������������������������������������������������������������000444��001750��001750�� 172�12626321255� 21161� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������host server1 host server2 server3 server4 host server-5 host server5.domain.name host server-6.domain.name #host server7 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/02base.t����������������������������������������������������������������������000444��001750��001750�� 16731�12626321255� 17227� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use FindBin qw($Bin); use lib "$Bin/../lib"; use Test::More; use Test::Trap; BEGIN { use_ok('App::ClusterSSH::Base') } # force default language for tests App::ClusterSSH::Base->set_lang('en'); my $base; $base = App::ClusterSSH::Base->new(); isa_ok( $base, 'App::ClusterSSH::Base' ); diag('testing output') if ( $ENV{TEST_VERBOSE} ); trap { $base->output('testing'); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout =~ tr/\n//, 1, 'got correct number of print lines' ); like( $trap->stdout, qr/\Atesting\n\Z/xsm, 'checking for expected print output' ); diag('Testing debug output') if ( $ENV{TEST_VERBOSE} ); for my $level ( 0 .. 9 ) { $base->set_debug_level($level); is( $base->debug_level(), $level, 'debug level is correct' ); trap { for my $log_level ( 0 .. 9 ) { $base->debug( $log_level, 'test' ); } }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout =~ tr/\n//, $level + 1, 'got correct number of debug lines' ); like( $trap->stdout, qr/(?:test\n){$level}/xsm, 'checking for expected debug output' ); } my $level; trap { $level = $base->set_debug_level(); }; isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); like( $trap->die, qr/^Debug level not provided/, 'Got correct croak text' ); $base->set_debug_level(10); is( $base->debug_level(), 9, 'checking debug_level reset to 9' ); $base = undef; trap { $base = App::ClusterSSH::Base->new( debug => 6, ); }; isa_ok( $base, 'App::ClusterSSH::Base' ); is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); like( $trap->stdout, qr/^Setting\slanguage\sto\s"en"/xsm, 'got expected new() output' ); $base = undef; trap { $base = App::ClusterSSH::Base->new( debug => 6, lang => 'en' ); }; isa_ok( $base, 'App::ClusterSSH::Base' ); is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); like( $trap->stdout, qr/^Setting\slanguage\sto\s"en"/xsm, 'got expected new() output' ); $base = undef; trap { $base = App::ClusterSSH::Base->new( debug => 6, lang => 'rubbish' ); }; isa_ok( $base, 'App::ClusterSSH::Base' ); is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); like( $trap->stdout, qr/^Setting\slanguage\sto\s"rubbish"/xsm, 'got expected new() output' ); $base = undef; trap { $base = App::ClusterSSH::Base->new( debug => 7, ); }; isa_ok( $base, 'App::ClusterSSH::Base' ); is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout =~ tr/\n//, 3, 'got new() debug output lines' ); like( $trap->stdout, qr/^Setting\slanguage\sto\s"en".Arguments\sto\sApp::ClusterSSH::Base->new.*debug\s=>\s7,$/xsm, 'got expected new() output' ); # config tests $base = undef; my $get_config; my $object; trap { $base = App::ClusterSSH::Base->new( debug => 3, ); }; isa_ok( $base, 'App::ClusterSSH::Base' ); is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); $base = undef; trap { $base = App::ClusterSSH::Base->new( debug => 3, parent => 'guardian' ); }; isa_ok( $base, 'App::ClusterSSH::Base' ); is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $base->parent, 'guardian', 'Expecting no STDOUT' ); trap { $get_config = $base->config(); }; isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); is( $trap->leaveby, 'die', 'died ok' ); like( $trap->die, qr/^config has not yet been set/, 'Got correct croak text' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Expecting not STDOUT' ); is( $get_config, undef, 'config left empty' ); trap { $object = $base->set_config(); }; isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); is( $trap->leaveby, 'die', 'died ok' ); like( $trap->die, qr/^passed config is empty/, 'Got correct croak text' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); trap { $object = $base->set_config('set to scalar'); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'config set ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); like( $trap->stdout, qr/^Setting\sapp\sconfiguration/xsm, 'Got expected STDOUT' ); isa_ok( $object, 'App::ClusterSSH::Base' ); trap { $get_config = $base->config(); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Expecting not STDOUT' ); is( $get_config, 'set to scalar', 'config set as expected' ); trap { $object = $base->set_config('set to another scalar'); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); like( $trap->die, qr/^config\shas\salready\sbeen\sset/, 'config cannot be reset' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Got expected STDOUT' ); trap { $object = $base->set_config(); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); like( $trap->die, qr/^config\shas\salready\sbeen\sset/, 'config cannot be reset' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Got expected STDOUT' ); # basic checks - validity of config is tested elsewhere my %config; trap { %config = $object->load_file; }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); is( $trap->die, q{"filename" arg not passed}, 'missing filename arg die message' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stdout, '', 'Got expected STDOUT' ); trap { %config = $object->load_file( filename => $Bin . '/15config.t.file1' ); }; is( $trap->leaveby, 'die', 'died ok' ); isa_ok( $trap->die, 'App::ClusterSSH::Exception', 'Caught exception object OK' ); is( $trap->die, q{"type" arg not passed}, 'missing type arg die message' ); is( $trap->stderr, '', 'Expecting no STDERR' ); done_testing(); ���������������������������������������App-ClusterSSH-4.05/t/30cluster.file1���������������������������������������������������������������000444��001750��001750�� 13�12626321255� 20436� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������tag1 host1 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/05getopts.t�������������������������������������������������������������������000444��001750��001750�� 36225�12626321255� 20005� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # Force use of English in tests for the moment, for those users that # have a different locale set, since errors are hardcoded below use POSIX qw(setlocale locale_h); setlocale( LC_ALL, "C" ); package Test::ClusterSSH::Mock; # generate purpose object used to simplfy testing sub new { my ( $class, %args ) = @_; my $config = { comms => 'testing', key_addhost => 'x', key_clientname => 'x', key_localname => 'x', key_quit => 'x', key_retilehosts => 'x', key_username => 'x', %args }; return bless $config, $class; } sub parent { my ($self) = @_; return $self; } sub VERSION { my ($self) = @_; return 'TESTING'; } sub config { my ($self) = @_; return $self; } sub load_configs { my ($self) = @_; return $self; } sub config_file { my ($self) = @_; return {}; } 1; package main; use FindBin qw($Bin); use lib "$Bin/../lib"; use Test::More; use Test::Trap; BEGIN { use_ok('App::ClusterSSH::Getopt') } my $getopts; my $mock_object = Test::ClusterSSH::Mock->new(); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); isa_ok( $getopts, 'App::ClusterSSH::Getopt' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on new object okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); isa_ok( $getopts, 'App::ClusterSSH::Getopt' ); trap { $getopts->add_option(); }; is( $trap->leaveby, 'die', 'adding an empty option failed' ); is( $trap->die, q{No "spec" passed to add_option}, 'empty add_option message' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->add_option( spec => 'option' ); }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->option; }; is( $trap->leaveby, 'return', 'calling option' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option, undef, 'Expecting no die message' ); local @ARGV = '--option1'; $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->add_option( spec => 'option1' ); }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->option1; }; is( $trap->leaveby, 'return', 'calling option' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option1, 1, 'Expecting no die message' ); local @ARGV = ''; # @ARGV is never undef, but an empty string $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->add_option( spec => 'option1', default => 5 ); }; is( $trap->leaveby, 'return', 'adding an empty option with a default value' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->option1; }; is( $trap->leaveby, 'return', 'calling option' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option1, 5, 'correct default value' ); local @ARGV = ( '--option1', '8' ); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->add_option( spec => 'option1=i', default => 5, ); }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->option1; }; is( $trap->leaveby, 'return', 'calling option' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option1, 8, 'default value overridden' ); @ARGV = ( '--option1', '--option2', 'string', '--option3', '10' ); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->add_option( spec => 'hidden', hidden => 1, no_acessor => 1, ); }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->add_option( spec => 'option1', help => 'help for 1' ); }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->add_option( spec => 'option2|o=s', help => 'help for 2' ); }; is( $trap->leaveby, 'return', 'adding option2 failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->add_option( spec => 'option3|alt_opt|O=i', help => 'help for 3', default => 5 ); }; is( $trap->leaveby, 'return', 'adding option3 failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->option1; }; is( $trap->leaveby, 'return', 'calling option1' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option1, 1, 'option1 is as expected' ); trap { $getopts->option1; }; is( $trap->leaveby, 'return', 'calling option2' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option2, 'string', 'option2 is as expected' ); trap { $getopts->option3; }; is( $trap->leaveby, 'return', 'calling option3' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $getopts->option3, 10, 'option3 is as expected' ); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->add_common_ssh_options; }; is( $trap->leaveby, 'return', 'calling option2' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->add_common_session_options; }; is( $trap->leaveby, 'return', 'calling option2' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); my $pod; @ARGV = ('--generate-pod'); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); $getopts->add_option( spec => 'long_opt|l=s', help => 'long opt help', default => 'default string' ); $getopts->add_option( spec => 'another_long_opt|n=i', ); $getopts->add_option( spec => 'a=s', help => 'short option only', ); $getopts->add_option( spec => 'long', help => 'long option only', ); trap { $getopts->getopts; }; is( $trap->leaveby, 'exit', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); $pod = $trap->stdout; # run pod through a checker at some point as it should be 'clean' is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); @ARGV = ('--help'); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->getopts; }; is( $trap->leaveby, 'exit', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); @ARGV = ('-?'); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->getopts; }; is( $trap->leaveby, 'exit', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); @ARGV = ('-v'); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->getopts; }; is( $trap->leaveby, 'exit', 'version option exist okay' ); is( $trap->die, undef, 'no error when spec provided' ); like( $trap->stdout, qr/^Version: /, 'Version string correct' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); @ARGV = ('-@'); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object ); trap { $getopts->getopts; }; is( $trap->leaveby, 'exit', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); ok( defined( $trap->stdout ), 'Expecting no STDOUT' ); like( $trap->stderr, qr{Unknown option: @}, 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); # test some common options @ARGV = ( '--unique-servers', '--title', 'title', '-p', '22', '--autoquit', '--tile', '--autoclose', '10', ); $mock_object->{auto_close} = 0; $mock_object->{auto_quit} = 0; $mock_object->{window_tiling} = 0; $mock_object->{show_history} = 0; $mock_object->{use_all_a_records} = 1; $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $mock_object->{auto_close}, 10, 'auto_close set right' ); is( $mock_object->{auto_quit}, 1, 'auto_quit set right' ); is( $mock_object->{window_tiling}, 1, 'window_tiling set right' ); is( $mock_object->{show_history}, 0, 'show_history set right' ); is( $mock_object->{use_all_a_records}, 1, 'use_all_a_records set right' ); @ARGV = ( '--unique-servers', '--title', 'title', '-p', '22', '--autoquit', '--tile', '--show-history', '-A', ); $getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); is( $mock_object->{auto_close}, 10, 'auto_close set right' ); is( $mock_object->{auto_quit}, 0, 'auto_quit set right' ); is( $mock_object->{window_tiling}, 0, 'window_tiling set right' ); is( $mock_object->{show_history}, 1, 'show_history set right' ); is( $mock_object->{use_all_a_records}, 0, 'use_all_a_records set right' ); TODO: { local $TODO = "explitely test for duplicate options"; $getopts = App::ClusterSSH::Getopt->new( parent => Test::ClusterSSH::Mock->new() ); trap { $getopts->add_option( spec => 'option1' ); }; is( $trap->leaveby, 'return', 'adding an empty option failed' ); is( $trap->die, undef, 'no error when spec provided' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); trap { $getopts->add_option( spec => 'option1' ); }; is( $trap->leaveby, 'die', 'adding an empty option failed' ); is( $trap->die, "bling bling", 'no error when spec provided' ); is( $trap->stdout, 'bling bling', 'Expecting no STDOUT' ); is( $trap->stderr, 'bling bling', 'Expecting no STDERR' ); trap { $getopts->getopts; }; is( $trap->leaveby, 'return', 'getops on object with spec okay' ); is( $trap->stdout, '', 'Expecting no STDOUT' ); is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->die, undef, 'Expecting no die message' ); } done_testing; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������App-ClusterSSH-4.05/t/30cluster.file2���������������������������������������������������������������000444��001750��001750�� 120�12626321255� 20456� 0����������������������������������������������������������������������������������������������������ustar�00dferguson�����������������������dferguson�����������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# a comment tag1 host1 tag2 host2 #line wrapped tag3 host3 \ host4 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������