pax_global_header00006660000000000000000000000064122661741470014524gustar00rootroot0000000000000052 comment=58bd88a023ea9192ffc1641e096bb91cb8f8b998 .gitignore000066400000000000000000000001451226617414700130600ustar00rootroot00000000000000*.swp *.tar.gz Build MANIFEST.bak MYMETA.json MYMETA.yml Makefile _build/ blib/ cover_db/ pm_to_blib AUTHORS000066400000000000000000000001511226617414700121350ustar00rootroot00000000000000Authors of clusterssh This utility was written by Duncan Ferguson (duncan_ferguson@users.sf.net). $Id$ Build.PL000066400000000000000000000026121226617414700123650ustar00rootroot00000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( meta_merge => { resources => { Repository => [ 'http://clusterssh.git.sourceforge.net/', 'http://github.com/duncs/clusterssh', ], bugtracker => 'http://sourceforge.net/tracker/?group_id=89139', homepage => 'http://clusterssh.sourceforge.net/', }, }, 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, }, 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, }, configure_requires => { 'Module::Build' => 0, }, add_to_cleanup => ['App-ClusterSSH-*'], create_makefile_pl => 'traditional', script_files => 'bin', ); $build->create_build_script; Changes000066400000000000000000000434301226617414700123670ustar00rootroot00000000000000????-??-?? Duncan Ferguson - v4.02_03 - Fix 'File->Show History' (Sf support request 41) - Amend 'tag-file' short option to 'r' to avoid option clash 2014-01-13 Duncan Ferguson - v4.02_02 - 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 2013-04-16 Duncan Ferguson - v4.02_01 - 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) 2013-03-05 Duncan Ferguson - v4.01_05 - 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 2013-02-26 Duncan Ferguson - v4.01_04 - Fixed 'ccon' not calling the correct command (Sf bug 3605002) - Fixed clusters not being defined correctly within the .clusterssh/config file (Sf bug 3605675) 2013-02-15 Duncan Ferguson - v4.01_03 * 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) 2012-12-09 Duncan Ferguson - v4.01_02 * 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 2011-12-09 Duncan Ferguson - v4.01_01 * Include missing files from release tarballs 2011-12-03 Duncan Ferguson - v4.01_00 * 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 2011-07-28 Duncan Ferguson - v4.00_11 * Fix '-l ' option (SF bug 3380675) 2011-07-08 Duncan Ferguson - v4.00_10 * Fix 'uninitialised error' message 2011-06-30 Duncan Ferguson - v4.00_09 * Cater for missing 'pod2text' command (Thanks to Sami Kerola) * Fix 'uninitialised variable' error * Added 'ccon' command (Thanks to Brandon Perkins) 2011-04-01 Duncan Ferguson - v4.00_08 * Amend all L links to prevent build breakage on cygwin (Sf bug 3115635) 2011-01-24 Duncan Ferguson - v4.00_07 * Fix for parsing config files with empty values (Stefan Steiner) * Reinstate acting on '-l username' option (reported by Ryan Brown) 2010-09-20 Duncan Ferguson - v4.00_06 * 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) 2010-06-20 Duncan Ferguson - v4.00_05 * 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 2010-06-20 Duncan Ferguson - v4.00_04 * Update MANIFEST file to ensure all correct files are included in release 2010-06-20 Duncan Ferguson - v4.00_03 * Fix silly type in code/tests 2010-06-19 Duncan Ferguson - v4.00_02 * 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 2010-01-08 Duncan Ferguson - v4.00_01 * Remove GNU tools and switch to Perl module layout using Module::Build 0000-00-00 Duncan Ferguson - v3.29 - unreleased * Handle hostnames containing % properly (Debian bug 543368) - Thanks to Tony Mancill for the patch 2009-12-19 Duncan Ferguson - v3.28 * 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) 2009-09-24 Duncan Ferguson - v3.27 * 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 2009-06-02 Duncan Ferguson - v3.26-1 * 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 2009-03-26 Duncan Ferguson - v3.25-1 * 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 2008-11-14 Duncan Ferguson - v3.24-1 * 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 2008-01-23 Duncan Ferguson - v3.23-1 * Apply bugfix supplied by Jima - Ensure loading of hosts from user ssh config file is case insensitive 2008-01-23 Duncan Ferguson - v3.22-1 * 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 2007-11-28 Duncan Ferguson - v3.21-1 * Implement a basic history window in the console (option -s) * Fixed bug whereby username@ wasn't being used correctly 2007-11-26 Duncan Ferguson - v3.20-1 * 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 2006-07-24 Duncan Ferguson - v3.19.1-1 - 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 2005-11-28 Duncan Ferguson - v3.18.1-1 * 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 2005-06-24 Duncan Ferguson - v3.17.1 * 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 2005-06-13 Duncan Ferguson - v3.16.1 * Allow ignoring of unresolved hosts (i.e. if hostname aliased in ssh config file) 2005-06-09 Duncan Ferguson - v3.15.1 * 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 2005-06-04 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.14.1 * first cut at terminal opening speed up 2005-05-20 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.13.1 * Bugfix for whitespace in config files (missing a char from regexp) * Allow for minimising/maximising all windows when done on console 2005-05-19 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.12.1 * Bugfix for shifted non-alphanumeric keyboard chars not being pasted correctly * Marked version number with 3rd digit to signify beta releases 2005-05-18 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.11 * Remove trailing whitespace from config file lines * Prevent paste events being sent to non-active clients * Allow paste events to send capitalised letters 2005-05-17 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.10 * fix for moving atom numbers in font info 2005-05-11 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.9 * 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 2005-05-09 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.8 * 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) 2005-05-05 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.7 * Found ConfigureWindow instead of ResizeMoveWindow 2005-05-05 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.6 * 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 2005-05-03 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.5 * 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 2005-04-26 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.4 * 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 2005-04-10 Duncan Ferguson <duncan_ferguson@user.sf.net> - v3.3 * src/cssh.pl: Rewritten from scratch * Set up to use Gnu Autotools $Id$ ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������MANIFEST��������������������������������������������������������������������������������������������0000664�0000000�0000000�00000001317�12266174147�0012223�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������AUTHORS bin/ccon bin/crsh bin/cscp bin/cssh bin/ctel Build.PL Changes lib/App/ClusterSSH.pm lib/App/ClusterSSH/Base.pm lib/App/ClusterSSH/Cluster.pm lib/App/ClusterSSH/Config.pm lib/App/ClusterSSH/Helper.pm lib/App/ClusterSSH/Host.pm lib/App/ClusterSSH/L10N.pm lib/App/ClusterSSH/L10N/en.pm Makefile.PL MANIFEST MANIFEST.SKIP META.json META.yml README t/00-load.t t/01l10n.t t/02base.t t/10host.t t/10host_ssh_config 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/external_cluster_command t/manifest.t t/pod-coverage.t t/pod.t THANKS TODO �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������MANIFEST.SKIP���������������������������������������������������������������������������������������0000664�0000000�0000000�00000000261�12266174147�0012765�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������^App-ClusterSSH-.* ^blib/ ^_build/ ^Build$ ^cover_db/ ^.git/ ^.gitignore ^Makefile$ ^Makefile.old$ ^MANIFEST\.bak$ MYMETA.json MYMETA.yml pm_to_blib .*\.swp$ ^TOAD$ ^WIP_TASKS$ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������META.json�������������������������������������������������������������������������������������������0000664�0000000�0000000�00000005046�12266174147�0012516�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{ "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.4003, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "App-ClusterSSH", "prereqs" : { "build" : { "requires" : { "File::Temp" : "0", "File::Which" : "0", "Readonly" : "0", "Test::Differences" : "0", "Test::DistManifest" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Trap" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0" } }, "runtime" : { "requires" : { "Exception::Class" : "1.31", "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.02_02" }, "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::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", "version" : 0 }, "App::ClusterSSH::L10N::en" : { "file" : "lib/App/ClusterSSH/L10N/en.pm", "version" : 0 } }, "release_status" : "testing", "resources" : { "bugtracker" : { "web" : "http://sourceforge.net/tracker/?group_id=89139" }, "homepage" : "http://clusterssh.sourceforge.net/", "license" : [ "http://dev.perl.org/licenses/" ], "x_Repository" : [ "http://clusterssh.git.sourceforge.net/", "http://github.com/duncs/clusterssh" ] }, "version" : "4.02_02" } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������META.yml��������������������������������������������������������������������������������������������0000664�0000000�0000000�00000003124�12266174147�0012341�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������--- abstract: 'A container for functions of the ClusterSSH programs' author: - 'Duncan Ferguson <duncan_j_ferguson@yahoo.co.uk>' build_requires: File::Temp: 0 File::Which: 0 Readonly: 0 Test::Differences: 0 Test::DistManifest: 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.4003, CPAN::Meta::Converter version 2.120921' 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.02_02 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::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 version: 0 App::ClusterSSH::L10N::en: file: lib/App/ClusterSSH/L10N/en.pm version: 0 requires: Exception::Class: 1.31 Locale::Maketext: 0 Tk: 800.022 Try::Tiny: 0 X11::Protocol: 0.56 version: 0 resources: bugtracker: http://sourceforge.net/tracker/?group_id=89139 homepage: http://clusterssh.sourceforge.net/ license: http://dev.perl.org/licenses/ x_Repository: - http://clusterssh.git.sourceforge.net/ - http://github.com/duncs/clusterssh version: 4.02_02 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Makefile.PL�����������������������������������������������������������������������������������������0000664�0000000�0000000�00000002034�12266174147�0013041�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Note: this file was auto-generated by Module::Build::Compat version 0.4003 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'App::ClusterSSH', 'VERSION_FROM' => 'lib/App/ClusterSSH.pm', 'PREREQ_PM' => { 'Exception::Class' => '1.31', 'File::Temp' => 0, 'File::Which' => 0, 'Locale::Maketext' => 0, 'Readonly' => 0, 'Test::Differences' => 0, 'Test::DistManifest' => 0, 'Test::Pod' => 0, 'Test::Pod::Coverage' => 0, 'Test::Trap' => 0, 'Tk' => '800.022', 'Try::Tiny' => 0, 'X11::Protocol' => '0.56', 'version' => '0' }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [ 'bin/ccon', 'bin/crsh', 'bin/cscp', 'bin/cssh', 'bin/ctel' ], 'PL_FILES' => {} ) ; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������README����������������������������������������������������������������������������������������������0000664�0000000�0000000�00000003507�12266174147�0011755�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 http://clusterssh.sourceforge.net 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 SourceForge project page http://clusterssh.sourceforge.net http://sourceforge.net/projects/clusterssh/ Project support area https://sourceforge.net/projects/clusterssh/support 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-2010 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. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������THANKS����������������������������������������������������������������������������������������������0000664�0000000�0000000�00000001376�12266174147�0012012�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������TODO������������������������������������������������������������������������������������������������0000664�0000000�0000000�00000002604�12266174147�0011562�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ����������������������������������������������������������������������������������������������������������������������������WIP_TASKS�������������������������������������������������������������������������������������������0000664�0000000�0000000�00000000000�12266174147�0012405�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������bin/������������������������������������������������������������������������������������������������0000775�0000000�0000000�00000000000�12266174147�0011640�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������bin/ccon��������������������������������������������������������������������������������������������0000777�0000000�0000000�00000000000�12266174147�0013363�2cssh������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������bin/crsh��������������������������������������������������������������������������������������������0000777�0000000�0000000�00000000000�12266174147�0013400�2cssh������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������bin/cscp��������������������������������������������������������������������������������������������0000775�0000000�0000000�00000013247�12266174147�0012525�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������bin/cssh��������������������������������������������������������������������������������������������0000775�0000000�0000000�00000057777�12266174147�0012555�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/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(); __END__ =pod =head1 NAME cssh, crsh, ctel, ccon - Cluster administration tool =head1 SYNOPSIS S<< cssh [options] [[user@]<server>[:port]|<tag>] [...] >> S<< crsh [options] [[user@]<server>[:port]|<tag>] [...] >> S<< ctel [options] [<server>[:port]|<tag>] [...] >> S<< ccon [options] [[user@]<server>[:port]|<tag>] [...] >> =head1 DESCRIPTION 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 via ssh so a correctly installed and configured ssh installation is required. If, however, the program is called by "crsh" then the rsh protocol is used (and the communications channel is insecure), or by "ctel" then telnet is used, or by "ccon" then console is used. Extra caution should be taken when editing system files such as /etc/inet/hosts as lines may not necessarily be in the same order. Assuming line 5 is the same across all servers and modifying that is dangerous. Better to search for the specific line to be changed and double-check before changes are committed. =head2 Further Notes Please also see L</KNOWN BUGS>. =over =item * 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. =item * 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. =item * If your window manager menu bars are obscured by terminal windows see the C<screen_reserve_XXXXX> options in the F<$HOME/.clusterssh/config> file (see L</"FILES">). =item * If the terminals overlap too much see the C<terminal_reserve_XXXXX> options in the F<$HOME/.clusterssh/config> file (see L</"FILES">). =item * If the code is called as crsh instead of cssh (i.e. a symlink called crsh points to the cssh file or the file is renamed) rsh is used as the communications protocol instead of ssh. =item * If the code is called as ctel instead of cssh (i.e. a symlink called ctel points to the cssh file or the file is renamed) telnet is used as the communications protocol instead of ssh. =item * If the code is called as ccon instead of cssh (i.e. a symlink called ccon points to the cssh file or the file is renamed) console is used as the communications protocol instead of ssh. =item * When using cssh on a large number of systems to connect back to a single system (e.g. you issue a command to the cluster to scp a file from a given location) and when these connections require authentication (i.e. you are going to authenticate with a password), the sshd daemon at that location may refuse connects after the number specified by MaxStartups in 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 ~/.ssh/authorized_keys mechanism for authentication if you encounter this problem. =item * If client windows fail to open, try running: C<< cssh -e {single host name} >> This will test the mechanisms used to open windows to hosts. This could be due to either the C<-xrm> terminal option which enables C<AllowSendEvents> (some terminal do not require this option, other terminals have another method for enabling it - see your terminal documention) or the C<ConnectTimeout> ssh option (see the configuration option C<-o> or file C<$HOME/.clusterssh/config> below to resolve this). =back =head1 OPTIONS Some of these options may also be defined within the configuration file. Default options are shown as appropriate. =over =item --action,-a '<command>' Run the command in each session, i.e. C<-a 'vi /etc/hosts'> to drop straight into a vi session. NOTE: not all communications methods support this (ssh and rsh should, telnet and console will not). =item --autoclose,-A <seconds> Number of seconds to wait before closing finished terminal windows. =item --autoquit,-q|--no-autoquit,-Q Enable|Disable automatically quiting after the last client window has closed (overriding the config file) =item --cluster-file,-c <file> Use supplied file as additional cluster file (see also L</"FILES">) =item --config-file,-C <file> Use supplied file as additional configuration file (see also L</"FILES">) =item -d DEPRECATED. See '--debug'. =item -D DEPRECATED. See '--debug'. =item --debug [number]. Enable debugging. Either a level can be provided or the option can be repeated multiple times. Maximum level is 4. =item --evaluate,-e [user@]<hostname>[:port] Display and evaluate the terminal and connection arguments so display any potential errors. The <hostname> is required to aid the evaluation. =item --font,-f "5x8" Specify the font to use in the terminal windows. Use standard X font notation. =item --help,-h|-? Show basic help text, and exit =item --list, -L List available cluster tags. =item --man,-H Show full help test (the man page), and exit =item --master,-M <master> The console client program polls master as the primary server, rather than the default set at compile time (typically ``console''). =item --options,-o "-x -o ConnectTimeout=10" - for ssh connections =item --options,-o "" - for rsh connections Specify arguments to be passed to ssh or rsh when making the connection. B<NOTE:> any "generic" change to the method (i.e. specifying the ssh port to use) should be done in the medium's own config file (see C<ssh_config> and F<$HOME/.ssh/config>). =item --output-config,-u Output the current configuration in the same format used by the F<$HOME/.clusterssh/config> file. =item --port,-p <port> Specify an alternate port for connections. =item --show-history,-s IN BETA: Show history within console window. This code is still being worked upon, but may help some users. =item --tag-file,-r <file> Use supplied file as additional tag file (see also L</"FILES">) =item --term-args,-t "" Specify arguments to be passed to terminals being used =item --tile,-g|--no-tile,-G Enable|Disable window tiling (overriding the config file) =item --title,-T "CSSH" Specify the initial part of the title used in the console and client windows =item --unique-servers,-m Connect to each host only once =item --use_all_a_records,-A 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) =item --username,-l $LOGNAME Specify the default username to use for connections (if different from the currently logged in user). B<NOTE:> will be overridden by <user>@<host> =item --version,-v Show version information and exit =back =head1 ARGUMENTS The following arguments are support: =over =item [user@]<hostname>[:port] ... Open an xterm to the given hostname and connect to the administration console. An optional port number can be used if sshd is not listening on standard port (e.g not listening on port 22) and ssh_config cannot be used. =item <tag> ... Open a series of xterms defined by <tag> in one of the suplimentary configuration files (see L</"FILES">). Note: specifying a username on a cluster tag will override any usernames defined in the cluster =back =head1 KEY SHORTCUTS The following key shortcuts are available within the console window, and all of them may be changed via the configuration files. =over =item Control-q Quit the program and close all connections and windows =item Control-+ Open the 'Add Host(s) or Cluster(s)' dialogue box. Mutiple host or cluster names can be entered, separated by spaces. =item Alt-n Paste in the hostname part of the specific connection string to each client, minus any username or port, i.e. C<< scp /etc/hosts server:files/<Alt-n>.hosts >> would replace the <Alt-n> with the client's name in each window =item Alt-r Retile all the client windows =back =head1 EXAMPLES =over =item Open up a session to 3 servers S<$ cssh server1 server2 server3> =item Open up a session to a cluster of servers identified by the tag 'farm1' and give the controlling window a specific title, where the cluster is defined in one of the default configuration files S<$ cssh -T 'Web Farm Cluster 1' farm1> =item Connect to different servers using different login names. NOTE: this can also be achieved by setting up appropriate options in the F<.ssh/config> file. Do not close cssh when last terminal exits. S<$ cssh -Q user1@server1 admin@server2> =item Open up a cluster defined in a non-default configuration file S<$ cssh -c $HOME/cssh.config db_cluster> =item Use telnet on port 2022 instead of ssh S<$ ctel -p 2022 server1 server2> =item Use rsh instead of ssh S<$ crsh server1 server2> =item Use console with master as the primary server instead of ssh S<$ ccon -M master server1 server2> =back =head1 FILES =over =item F</etc/clusters>, F<$HOME/.clusterssh/clusters> 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 formated is as follows: S<< <tag> [user@]<server> [user@]<server> [...] >> i.e. # List of servers in live live admin1@server1 admin2@server2 server3 server4 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. Extra cluster files may also be specified either as an option on the command line (see C<cluster-file>) or in the users F<$HOME/.clusterssh/config> file (see C<extra_cluster_file> configuration option). NOTE: the last tag read overwrites any pre-existing tag of that name NOTE: there is a special cluster tag called C<default> - any tags or hosts included within this tag will be automatically opened if no other tags are specified on the command line. =item F</etc/tags>, F<$HOME/.clusterssh/tags> Very similar to F<cluster> files but the definition is reversed. The format is: S<< <host> <tag> [...] >> This allows one host to be specified as a member of a number of tags. This format can be clearer than using F<clusters> files. Extra tag files may be spcieid either an an option (see C<tag-file>) or within the users F<$HOME/.clusterssh/config> file (see C<extra_tag_file> configuration option). NOTE: All tags are added together =item F</etc/csshrc> & F<$HOME/.clusterssh/config> 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. B<NOTE:> values for entries do not need to be quoted unless it is required for passing arguments, i.e. terminal_allow_send_events="-xrm '*.VT100.allowSendEvents:true'" should be written as terminal_allow_send_events=-xrm '*.VT100.allowSendEvents:true' =over =item auto_close = 5 Close terminal window after this many seconds. If set to 0 will instead wait on input from the user in each window before closing. Can be overridden by C<-K> on the command line =item auto_quit = yes Automatically quit after the last client window closes. Set to anything other than "yes" to disable. Can be overridden by C<-Q> on the command line. =item clusters = <blank> Define a number of cluster tags in addition to (or to replace) tags defined in the F</etc/clusters> file. The format is: clusters = <tag1> <tag2> <tag3> <tag1> = host1 host2 host3 <tag2> = user@host4 user@host5 host6 <tag3> = <tag1> <tag2> As with the F</etc/clusters> file, be sure not to create recursivly nested tags. =item comms = ssh Sets the default communication method (initially taken from the name of program, but can be overridden here). =item console_position = <null> 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). =item external_cluster_command = <null> 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 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. =item extra_cluster_file = <null> Define an extra cluster file in the format of F</etc/clusters>. Multiple files can be specified, seperated by commas. Both ~ and $HOME are acceptable as a to reference the users home directory, i.e. extra_cluster_file = ~/clusters, $HOME/clus =item ignore_host_errors THIS OPTION IS DEPRECATED. It has been left in so current systems continue to function as expected. =item key_addhost = Control-Shift-plus Default key sequence to open AddHost menu. See below notes on shortcuts. =item key_clientname = Alt-n Default key sequence to send cssh client names to client. See below notes on shortcuts. =item key_localname = Alt-l Default key sequence to send hostname of local server to client. See below notes on shortcuts. =item key_paste = Control-v Default key sequence to paste text into the console window. See below notes on shortcuts. =item key_quit = Control-q Default key sequence to quit the program (will terminate all open windows). See below notes on shortcuts. =item key_retilehosts = Alt-r Default key sequence to retile host windows. See below notes on shortcuts. =item key_username = Alt-u Default key sequence to send username to client. See below notes on shortcuts. =item macro_servername = %s =item macro_hostname = %h =item macro_username = %u =item macro_newline = %n =item macro_version = %v Change the replacement macro used when either using a 'Send' menu item, or when pasting text into the main console. =item macros_enabled = yes Enable or disable macro replacement. Note: this affects pasting into the main console, items on the 'Send' menu and key_clientname, key_localname, key_servername and key_username. =item max_addhost_menu_cluster_items = 6 Maximum number of entries in the 'Add Host' menu cluster list before scrollbars are used =item max_host_menu_items = 30 Maximum number of hosts to put into the host menu before starting a new column =item menu_host_autotearoff = 0 =item menu_send_autotearoff = 0 When set to non-0 will automatically tear-off the host or send menu at program start =item mouse_paste = Button-2 (middle mouse button) Default key sequence to paste text into the console window using the mouse. See below notes on shortcuts. =item rsh = rsh =item ssh = ssh =item telnet = telnet Set the path to the specific binary to use for the communication method, else uses the first match found in $PATH =item rsh_args = <blank> =item ssh_args = "-x -o ConnectTimeout=10" =item telnet_args = <blank> 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 (i.e. specifying the ssh port to use) should be done in the medium's own config file (see C<ssh_config> and F<$HOME/.ssh/config>). =item screen_reserve_top = 0 =item screen_reserve_bottom = 60 =item screen_reserve_left = 0 =item screen_reserve_right = 0 Number of pixels from the screen 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. =item rsh = /path/to/rsh =item ssh = /path/to/ssh Depending on the value of comms, set the path of the communication binary. =item terminal = /path/to/terminal Path to the x-windows terminal used for the client. =item terminal_args = <blank> Arguments to use when opening terminal windows. Otherwise takes defaults from F<$HOME/.Xdefaults> or $<$HOME/.Xresources> file. =item terminal_font = 6x13 Font to use in the terminal windows. Use standard X font notation. =item terminal_reserve_top = 5 =item terminal_reserve_bottom = 0 =item terminal_reserve_left = 5 =item terminal_reserve_right = 0 Number of pixels from the terminal 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. =item terminal_colorize = 1 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. =item terminal_bg_style = dark If set to dark, the the terminal background will be set to black and the foreground to the pseudo-random color. If set to light, then the foreground will be black and the background the pseudo-random color. If terminal_colorize is zero, then this option has no effect. =item terminal_size = 80x24 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)) =item terminal_title_opt = -T Option used with C<terminal> to set the title of the window =item terminal_allow_send_events = -xrm '*.VT100.allowSendEvents:true' Option required by the terminal to allow XSendEvents to be received =item title = cssh Title of windows to use for both the console and terminals. =item unmap_on_redraw = no 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. =item use_all_a_records = no If a hostname resolves to multiple IP addresses, set to C<yes> to connect to all of them, not just the first one found. =item use_hotkeys = yes Setting to anything other than C<yes> will disable all hotkeys. =item user = $LOGNAME Sets the default user for running commands on clients. =item window_tiling = yes Perform window tiling (set to C<no> to disable) =item window_tiling_direction = right Direction to tile windows, where "right" means starting top left and moving right and then down, and anything else means starting bottom right and moving left and then up =back B<NOTE:> The key shortcut modifiers must be in the form "Control", "Alt", or "Shift", i.e. with the first letter capitalised and the rest lower case. Keys may also be disabled individually by setting to the word "null". =item F<$HOME/.csshrc_send_menu> This (optional) file contains items to populate the send menu. The default entry could be written as: <send_menu> <menu title="Use Macros"> <toggle/> <accelerator>ALT-p</accelerator> </dmenu> <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> Submenus can also be specified as follows: <send_menu> <menu title="Default Entries"> <detach>yes</detach> <menu title="Hostname"> <command>%s</command> <accelerator>ALT-n</accelerator> </menu> </menu> </send_menu> B<Caveats:> =over 4 =item There is currently no strict format checking of this file. =item The format of the file may change in the future =item If the file exists the default entry (Hostname) is not added =back The following replacement macros are available (note: these can be changed in the configuration file): =over 4 =item %s Hostname part of the specific connection string to each client, minus any username or port =item %u Username part of the connection string to each client =item %h Hostname of server where cssh is being run from =item %n <RETURN> code =back B<NOTE:> requires L<XML::Simple> to be installed =back =head1 KNOWN BUGS =over 4 =item 1. Catering for IPv6 addresses is minimal. This is due to a conflict between IPv6 addresses and port numbers within the same server definition since they both use the same seperator, i.e. is the following just an IPv6 address, or an address + port number of 2323? 2001:db8::1428:2323 Exactly - I cannot tell either. the IPv6 address without a port is assumed in those cases where it cannot be determined and a warning is issued. Possible work arounds include: =over 4 =item a. Use square brackets around the IPv6 address, i.e. [2001:db8::1428]:2323 or [2001:db8::1428:2323] as appropriate so there is no ambiguity =item b. Use the full IPv6 address if also using a port number - the 8th colon is assumed to be the port seperator. =item c. Define the IPv6 address in your /etc/hosts file, DNS or other name service lookup mechanism and use the hostname instead of the address. =back =item 2. Swapping virtual desktops can 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) =back Anyone with any good ideas to fix the above bugs is more than welcome to get in touch and/or provide a patch. =head1 REPORTING BUGS =over 2 =item * If you have issues running cssh, first try: C<< cssh -e [user@]<hostname>[:port] >> This performs two tests to confirm cssh is able to work properly with the settings provided within the F<$HOME/.clusterssh/config> file (or internal defaults). 1. test the terminal window works with the options provided 2. test ssh works to a host with the configured arguments Configuration options to watch for in ssh are - Doesnt understand "-o ConnectTimeout=10" - remove the option in the F<$HOME/.clusterssh/config> file - OpenSSH-3.8 using untrusted ssh tunnels - use "-Y" instead of "-X" or use "ForwardX11Trusted yes' in ssh_config (if you change the default ssh options from -x to -X) =item * If you require support, please run the following commands and post it on the web site in the support/problems forum: C<< perl -V >> C<< perl -MTk -e 'print $Tk::VERSION,$/' >> C<< perl -MX11::Protocol -e 'print $X11::Protocol::VERSION,$/' >> C<< cat /etc/csshrc $HOME/.clusterssh/config >> =item * Use the debug switches (-d, -D, or -dD) will turn on debugging output. However, please only use this option with one host at a time, i.e. "cssh -d <host>" due to the amount of output produced (in both main and child windows). =back =head1 SEE ALSO L<http://clusterssh.sourceforge.net/>, C<ssh>, L<Tk::overview>, L<X11::Protocol>, C<perl> =head1 CREDITS A web site for comments, requests, bug reports and bug fixes/patches is available at L<http://clusterssh.sourceforge.net/> =head1 AUTHOR Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >> =head1 LICENSE AND COPYRIGHT Copyright 1999-2010 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; �bin/ctel��������������������������������������������������������������������������������������������0000777�0000000�0000000�00000000000�12266174147�0013370�2cssh������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/������������������������������������������������������������������������������������������������0000775�0000000�0000000�00000000000�12266174147�0011636�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/��������������������������������������������������������������������������������������������0000775�0000000�0000000�00000000000�12266174147�0012356�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH.pm�������������������������������������������������������������������������������0000664�0000000�0000000�00000203102�12266174147�0014711�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH; use 5.008.004; use warnings; use strict; use version; our $VERSION = version->new('4.02_03'); use Carp; use base qw/ App::ClusterSSH::Base /; use App::ClusterSSH::Host; use App::ClusterSSH::Config; use App::ClusterSSH::Helper; use App::ClusterSSH::Cluster; use FindBin qw($Script); use POSIX ":sys_wait_h"; use Pod::Usage; use Getopt::Long qw(:config no_ignore_case bundling no_auto_abbrev); 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 Net::hostent; use Carp; use Sys::Hostname; use English; use Socket; # 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 givwen 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->{config} = App::ClusterSSH::Config->new(); $self->{helper} = App::ClusterSSH::Helper->new(); $self->{cluster} = App::ClusterSSH::Cluster->new(); # catch and reap any zombies $SIG{CHLD} = \&REAPER; return $self; } sub config { my ($self) = @_; return $self->{config}; } sub cluster { my ($self) = @_; return $self->{cluster}; } sub helper { my ($self) = @_; return $self->{helper}; } sub REAPER { my $kid; do { $kid = waitpid( -1, WNOHANG ); logmsg( 2, "REAPER currently returns: $kid" ); } until ( $kid == -1 || $kid == 0 ); } # Command line options list my @options_spec = ( 'debug:+', 'd', # backwards compatibility - DEPRECATED 'D', # backwards compatibility - DEPRECATED 'version|v', 'help|h|?', 'man|H', 'action|a=s', 'cluster-file|c=s', 'tag-file|r=s', 'config-file|C=s', 'evaluate|e=s', 'tile|g', 'no-tile|G', 'username|l=s', 'master|M=s', 'options|o=s', 'port|p=i', 'autoquit|q', 'no-autoquit|Q', 'autoclose|K=i', 'history|s', 'term-args|t=s', 'title|T=s', 'output-config|u', 'font|f=s', 'list|L', 'use_all_a_records|A', 'unique-servers|m', ); my %options; 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; $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 $svr = shift; logmsg( 2, "Killing session for $svr" ); if ( !$servers{$svr} ) { logmsg( 2, "Session for $svr not found" ); return; } logmsg( 2, "Killing process $servers{$svr}{pid}" ); kill( 9, $servers{$svr}{pid} ) if kill( 0, $servers{$svr}{pid} ); delete( $servers{$svr} ); } # catch_all exit routine that should always be used sub exit_prog() { logmsg( 3, "Exiting via normal routine" ); # for each of the client windows, send a kill # to make sure we catch all children, even when they havnt # finished starting or received teh kill signal, do it like this while (%servers) { foreach my $svr ( keys(%servers) ) { terminate_host($svr); } } exit 0; } # output function according to debug level # $1 = log level (0 to 3) # $2 .. $n = list to pass to print sub logmsg($@) { my $level = shift; $level = 6 if ( $level > 6 ); if ( $level <= $options{debug} ) { print( strftime( "%H:%M:%S: ", localtime ) ) if ( $options{debug} > 1 ); print @_, $/; } } sub evaluate_commands { my ($self) = @_; my ( $return, $user, $port, $host ); # break apart the given host string to check for user or port configs print "{evaluate}=$options{evaluate}\n"; $user = $1 if ( $options{evaluate} =~ s/^(.*)@// ); $port = $1 if ( $options{evaluate} =~ s/:(\w+)$// ); $host = $options{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); exit_prog; } sub load_keyboard_map() { # 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? logmsg( 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 logmsg( 2, "Unknown keycode ", $keyboard[$i][$modifier] ); } } } } # dont 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 $keysym = shift; $keyboardmap{$keysym} =~ m/^(\D+)(\d+)$/; my ( $state, $code ) = ( $1, $2 ); logmsg( 2, "keyboardmap=:", $keyboardmap{$keysym}, ":" ); logmsg( 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"); } logmsg( 2, "returning state=:$state: code=:$code:" ); return ( $state, $code ); } sub resolve_names(@) { my ( $self, @servers ) = @_; logmsg( 2, 'Resolving cluster names: started' ); foreach (@servers) { my $dirty = $_; my $username = q{}; logmsg( 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 }; if ( $#alladdrs > 0 ) { $self->cluster->register_tag( $dirty, @alladdrs ); logmsg( 3, 'Expanded to ', $self->cluster->get_tag($dirty) ); } else { logmsg( 3, 'Only one A record' ); } } } if (@tag_list) { logmsg( 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( $self->config->{external_cluster_command}, @servers ); }; if ($@) { warn $@, $/; } else { @servers = @new_servers; } } # now clean the array up @servers = grep { $_ !~ m/^$/ } @servers; if ( $self->config->{unique_servers} ) { logmsg( 3, 'removing duplicate server names' ); @servers = remove_repeated_servers(@servers); } logmsg( 3, 'leaving with ', $_ ) foreach (@servers); logmsg( 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(); $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} ); logmsg( 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 send_text($@) { my $self = shift; my $svr = shift; my $text = join( "", @_ ); logmsg( 2, "servers{$svr}{wid}=$servers{$svr}{wid}" ); logmsg( 3, "Sending to '$svr' text:$text:" ); # command macro substitution if ( $self->config->{macros_enabled} eq 'yes' ) { # $svr contains a trailing space here, so ensure its stripped off { my $macro_servername = $self->config->{macro_servername}; my $servername = $svr; $servername =~ s/\s+//; $text =~ s/$macro_servername/$servername/xsmg; } $text =~ s/%h/hostname()/xsmeg; # use connection username, else default to current username { 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; } } 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}; logmsg( 2, "Looking for char :$char: with ord :$ord:" ); logmsg( 2, "Looking for keycode :$keycode:" ); logmsg( 2, "Looking for keysym :$keysym:" ); logmsg( 2, "Looking for keyboardmap :", $keyboardmap{$keysym}, ":" ); my ( $state, $code ) = get_keycode_state($keysym); logmsg( 2, "Got state :$state: code :$code:" ); for my $event (qw/KeyPress KeyRelease/) { logmsg( 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, 'time' => time(), '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_resizemove($$$$$) { my ( $win, $x_pos, $y_pos, $x_siz, $y_siz ) = @_; logmsg( 3, "Moving window $win to x:$x_pos y:$y_pos (size x:$x_siz y:$y_siz)" ); #logmsg( 2, "resize move normal: ", $xdisplay->atom('WM_NORMAL_HINTS') ); #logmsg( 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 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_givenname(); # 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 } logmsg( 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); logmsg( 2, "Working on server $server for $_" ); $servers{$server}{pipenm} = tmpnam(); logmsg( 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 ); 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} . "'", ); logmsg( 2, "Terminal exec line:\n$exec\n" ); exec($exec) == 0 or warn("Failed: $!"); } } # Now all the windows are open, get all their window id's 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 logmsg( 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}; logmsg( 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 } logmsg( 2, "All client windows opened" ); $self->config->{internal_total} = int( keys(%servers) ); return $self; } sub get_font_size() { my ($self) = @_; logmsg( 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" ); } logmsg( 2, "Done with font size" ); return $self; } sub show_console() { my ($self) = shift; logmsg( 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 called sub retile_hosts { my ( $self, $force ) = @_; $force ||= ""; logmsg( 2, "Retiling windows" ); my %config; if ( $self->config->{window_tiling} ne "yes" && !$force ) { logmsg( 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 logmsg( 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 ); logmsg( 2, "Screen Columns: ", $self->config->{internal_columns} ); logmsg( 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} ); logmsg( 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 ( $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 ) { logmsg( 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 { logmsg( 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) { logmsg( 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} ); } logmsg( 2, "Moving $server window" ); 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) ) { logmsg( 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) { logmsg( 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() { logmsg( 0, "Stub for capturing a terminal window" ); return if ( $options{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) = @_; logmsg( 2, "Toggling active state of all hosts" ); foreach my $svr ( sort( keys(%servers) ) ) { $servers{$svr}{active} = not $servers{$svr}{active}; } } sub close_inactive_sessions() { my ($self) = @_; logmsg( 2, "Closing all inactive sessions" ); foreach my $svr ( sort( keys(%servers) ) ) { terminate_host($svr) if ( !$servers{$svr}{active} ); } $self->build_hosts_menu(); } sub add_host_by_name() { my ($self) = @_; logmsg( 2, "Adding host to menu here" ); $windows{host_entry}->focus(); my $answer = $windows{addhost}->Show(); if ( $answer ne "Add" ) { $menus{host_entry} = ""; return; } if ( $menus{host_entry} ) { logmsg( 2, "host=", $menus{host_entry} ); my @names = $self->resolve_names( split( /\s+/, $menus{host_entry} ) ); logmsg( 0, 'Opening to: ', join( ' ', @names ) ); $self->open_client_windows(@names); } if ( defined $menus{listbox} && $menus{listbox}->curselection() ) { my @hosts = $menus{listbox}->get( $menus{listbox}->curselection() ); logmsg( 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(); } } sub build_hosts_menu() { my ($self) = @_; logmsg( 2, "Building hosts menu" ); # first, empty the hosts menu from the 4th entry on my $menu = $menus{bar}->entrycget( 'Hosts', -menu ); my $host_menu_static_items = 5; $menu->delete( $host_menu_static_items, 'end' ); logmsg( 3, "Menu deleted" ); # add back the seperator $menus{hosts}->separator; logmsg( 3, "Parsing list" ); my $menu_item_counter = $host_menu_static_items; foreach my $svr ( sort( keys(%servers) ) ) { logmsg( 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++; } logmsg( 3, "Changing window title" ); $self->change_main_window_title(); logmsg( 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; logmsg( 5, "Running repeat;count=", $self->config->{internal_count} ); #logmsg( 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; delete( $servers{$svr} ); logmsg( 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) ); #logmsg( 3, "Number after tidy is: ", $config{internal_total} ); # get current number of clients $self->config->{internal_total} = int( keys(%servers) ); #logmsg( 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} ) { logmsg( 2, "Autoquitting" ); exit_prog; } } # rebuild host menu if something has changed $self->build_hosts_menu() if ($build_menu); # clean out text area, anyhow $menus{entrytext} = ""; #logmsg( 3, "repeat completed" ); } ); logmsg( 2, "Repeat setup" ); return $self; } ### Window and menu definitions ### sub create_windows() { my ($self) = @_; logmsg( 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>' => \&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 { logmsg( 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; } logmsg( 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', ); if ( $self->config->{max_addhost_menu_cluster_items} && scalar $self->cluster->list_tags() ) { if (scalar scalar $self->cluster->list_tags() < $self->config->{max_addhost_menu_cluster_items} ) { $menus{listbox} = $windows{addhost}->Listbox( -selectmode => 'extended', -height => scalar $self->cluster->list_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 $self->cluster->list_tags() ); } $windows{host_entry} = $windows{addhost}->add( 'LabEntry', -textvariable => \$menus{host_entry}, -width => 20, -label => 'Host', -labelPack => [ -side => 'left', ], -class => 'cssh', )->pack( -side => 'left' ); logmsg( 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 { logmsg( 3, "Entering MAP" ); my $state = $windows{main_window}->state(); logmsg( 3, "state=$state previous=", $self->config->{internal_previous_state} ); logmsg( 3, "Entering MAP" ); if ( $self->config->{internal_previous_state} eq $state ) { logmsg( 3, "repeating the same" ); } if ( $self->config->{internal_previous_state} eq "mid-change" ) { logmsg( 3, "dropping out as mid-change" ); return; } logmsg( 3, "state=$state previous=", $self->config->{internal_previous_state} ); if ( $self->config->{internal_previous_state} eq "iconic" ) { logmsg( 3, "running retile" ); $self->retile_hosts(); logmsg( 3, "done with retile" ); } if ( $self->config->{internal_previous_state} ne $state ) { logmsg( 3, "resetting prev_state" ); $self->config->{internal_previous_state} = $state; } } ); # $windows{main_window}->bind( # '<Unmap>' => sub { # logmsg( 3, "Entering UNMAP" ); # # my $state = $windows{main_window}->state(); # logmsg( 3, # "state=$state previous=$config{internal_previous_state}" ); # # if ( $config{internal_previous_state} eq $state ) { # logmsg( 3, "repeating the same" ); # } # # if ( $config{internal_previous_state} eq "mid-change" ) { # logmsg( 3, "dropping out as mid-change" ); # return; # } # # if ( $config{internal_previous_state} eq "normal" ) { # logmsg( 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 ) { # logmsg( 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} = ""; logmsg( 3, "=========" ); logmsg( 3, "event =$event" ); logmsg( 3, "keysym =$keysym (state=$state)" ); logmsg( 3, "keysymdec=$keysymdec" ); logmsg( 3, "keycode =$keycode" ); logmsg( 3, "state =$state" ); logmsg( 3, "codetosym=$keycodetosym{$keysymdec}" ) if ( $keycodetosym{$keysymdec} ); logmsg( 3, "symtocode=$keysymtocode{$keysym}" ); logmsg( 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-//; logmsg( 3, "combo=$combo" ); foreach my $hotkey ( grep( /key_/, keys( %{ $self->config } ) ) ) { my $key = $self->config->{$hotkey}; next if ( $key eq "null" ); # ignore disabled keys logmsg( 3, "key=:$key:" ); if ( $combo =~ /^$key$/ ) { logmsg( 3, "matched combo" ); if ( $event eq "KeyRelease" ) { logmsg( 2, "Received hotkey: $hotkey" ); $self->send_text_to_all_servers('%s') if ( $hotkey eq "key_clientname" ); $self->send_text_to_all_servers('%h') if ( $hotkey eq "key_localname" ); $self->send_text_to_all_servers('%u') 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" ); exit_prog() if ( $hotkey eq "key_quit" ); } return; } } } # look for a <Control>-d and no hosts, so quit 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 ) { logmsg( 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, 'time' => time(), 'event' => $servers{$_}{wid}, 'root' => $xdisplay->root(), 'same_screen' => 1, ) ) || warn("Error returned from SendEvent: $!"); } } $xdisplay->flush(); return $self; } sub create_menubar() { my ($self) = @_; logmsg( 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 => \&exit_prog, -accelerator => $self->config->{key_quit}, ] ], -tearoff => 0, ); $menus{hosts} = $menus{bar}->cascade( -label => 'Hosts', -tearoff => 1, -menuitems => [ [ "command", "Retile Windows", -command => sub { $self->retile_hosts }, -accelerator => $self->config->{key_retilehosts}, ], # [ "command", "Capture Terminal", -command => \&capture_terminal, ], [ "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}, ], '', ], ); $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' ], ); logmsg( 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} ) { logmsg( 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} ); }, ); } else { logmsg( 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} ); logmsg( 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) = @_; ### main ### # Note: getopts returned "" if it finds any options it doesnt recognise # so use this to print out basic help pod2usage( -verbose => 1 ) if ( !GetOptions( \%options, @options_spec ) ); pod2usage( -verbose => 1 ) if ( $options{'?'} || $options{help} ); pod2usage( -verbose => 2 ) if ( $options{H} || $options{man} ); if ( $options{version} ) { print "Version: $VERSION\n"; exit 0; } $options{debug} ||= 0; # only get xdisplay if we got past usage and help stuff $xdisplay = X11::Protocol->new(); if ( !$xdisplay ) { die("Failed to get X connection\n"); } if ( $options{d} && $options{D} ) { $options{debug} += 3; logmsg( 0, 'NOTE: -d and -D are deprecated - use "--debug 3" instead' ); } elsif ( $options{d} ) { $options{debug} += 1; logmsg( 0, 'NOTE: -d is deprecated - use "--debug 1" instead' ); } elsif ( $options{D} ) { $options{debug} += 2; logmsg( 0, 'NOTE: -D is deprecated - use "--debug 2" instead' ); } # restrict to max level $options{debug} = 4 if ( $options{debug} && $options{debug} > 4 ); $self->set_debug_level( $options{debug} ); logmsg( 2, "VERSION: $VERSION" ); $self->config->load_configs( $options{'config-file'} ); if ( $options{use_all_a_records} ) { $self->config->{use_all_a_records} = !$self->config->{use_all_a_records} || 0; } if ( $options{action} ) { $self->config->{command} = $options{action}; } $self->config->{unique_servers} = 1 if $options{'unique-servers'}; $self->config->{auto_quit} = "yes" if $options{autoquit}; $self->config->{auto_quit} = "no" if $options{'no-autoquit'}; $self->config->{auto_close} = $options{autoclose} if defined $options{'autoclose'}; $self->config->{window_tiling} = "yes" if $options{tile}; $self->config->{window_tiling} = "no" if $options{'no-tile'}; $self->config->{user} = $options{username} if ( $options{username} ); $self->config->{port} = $options{port} if ( $options{port} ); $self->config->{show_history} = 1 if $options{'show-history'}; $self->config->{ssh_args} = $options{options} if ( $options{options} ); $self->config->{terminal_font} = $options{font} if ( $options{font} ); $self->config->{terminal_args} = $options{'term-args'} if ( $options{'term-args'} ); if ( $self->config->{terminal_args} =~ /-class (\w+)/ ) { $self->config->{terminal_allow_send_events} = "-xrm '$1.VT100.allowSendEvents:true'"; } $self->config->dump() if ( $options{'output-config'} ); $self->evaluate_commands() if ( $options{evaluate} ); $self->get_font_size(); load_keyboard_map(); # read in normal cluster files $self->config->{extra_cluster_file} .= ',' . $options{'cluster-file'} if ( $options{'cluster-file'} ); $self->config->{extra_tag_file} .= ',' . $options{'tag-file'} if ( $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 ( $options{'list'} ) { print( 'Available cluster tags:', $/ ); print "\t", $_, $/ foreach ( sort( $self->cluster->list_tags ) ); $self->debug( 4, "Full clusters dump: ", $self->_dump_args_hash( $self->cluster->dump_tags ) ); 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(); logmsg( 2, "Capture map events" ); $self->capture_map_events(); logmsg( 0, 'Opening to: ', join( ' ', @servers ) ); $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(); logmsg( 2, "Sleeping for a mo" ); select( undef, undef, undef, 0.5 ); logmsg( 2, "Sorting focus on console" ); $windows{text_entry}->focus(); logmsg( 2, "Marking main window as user positioned" ); $windows{main_window}->positionfrom('user') ; # user puts it somewhere, leave it there logmsg( 2, "Setting up repeat" ); $self->setup_repeat(); # Start event loop logmsg( 2, "Starting MainLoop" ); MainLoop(); # make sure we leave program in an expected way 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 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 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 logmsg =item new =item open_client_windows =item parse_config_file =item pick_color =item populate_send_menu =item populate_send_menu_entries_from_xml =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 setup_repeat =item show_console =item show_history =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-2010 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; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/���������������������������������������������������������������������������������0000775�0000000�0000000�00000000000�12266174147�0014355�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/Base.pm��������������������������������������������������������������������������0000664�0000000�0000000�00000020071�12266174147�0015565�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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', ); # Dont 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 ) = @_; $language = $lang; if ($self) { $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} || $args{type} !~ m/cluster|config/ ) { croak( App::ClusterSSH::Exception->throw( error => '"type" arg invalid' ) ); } $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; } 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 $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-2010 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; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/Cluster.pm�����������������������������������������������������������������������0000664�0000000�0000000�00000014214�12266174147�0016336�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 get_external_clusters { my ( $self, $external_command, @tags ) = @_; $self->debug( 3, 'Running tags through external command' ); $self->debug( 4, 'External command: ', $external_command ); $self->debug( 3, 'Tags: ', join( ',', @tags ) ); my $command = "$external_command @tags"; $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 sort 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 @resolved_tags=get_external_clusters($path_to_binary, @tags) Define and use an external script to resolve 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-2010 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; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/Config.pm������������������������������������������������������������������������0000664�0000000�0000000�00000035073�12266174147�0016130�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 /); # 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 => "Control-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, console => 'console', console_args => '', rsh => 'rsh', rsh_args => "", telnet => 'telnet', telnet_args => "", ssh => 'ssh', ssh_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} . '/.csshrc_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' ); # list of allowed comms methods if ( 'ssh rsh telnet 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} ), ), ); } # # Don't search for the path to the binary - assume it is on the path # # or defined correctly in the config. # if( !-e $self->{ $self->{comms} } ) # { # $self->{ $self->{comms} } = $self->find_binary( $self->{comms} ); # } 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; } # 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, "$binary already fully qualified" ); return $binary; } else { $self->debug( 2, "$binary not found - re-searching" ); $binary =~ s!^.*/!!; } } my $path; if ( !-x $binary || substr( $binary, 0, 1 ) ne '/' ) { foreach ( split( /:/, $ENV{PATH} ), qw! /bin /sbin /usr/sbin /usr/bin /usr/local/bin /usr/local/sbin /opt/local/bin /opt/local/sbin ! ) { $self->debug( 3, "Looking in $_" ); if ( -f $_ . '/' . $binary && -x $_ . '/' . $binary ) { $path = $_ . '/' . $binary; $self->debug( 2, "Found at $path" ); last; } } } 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->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-2010 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; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/Helper.pm������������������������������������������������������������������������0000664�0000000�0000000�00000011434�12266174147�0016135�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ) = @_; 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"; # # P = pipe file # # s = server # # u = username # # p = port # # m = ccon master # # c = comms command # # a = command args # # C = command to run # my $lelehelper_script = q{ # use strict; # use warnings; # use Getopt::Std; # my %opts; # getopts('PsupmcaC', \%opts); # my $command="$opts{c} $opts{a}"; # open(PIPE, ">", $opts{P}) 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($opts{s} =~ m/==$/) # { # $opts{s} =~ s/==$//; # warn("\nWARNING: failed to resolve IP address for $opts{s}.\n\n"); # sleep 5; # } # if($opts{m}) { # unless("$comms" ne "console") { # $opts{m} = $opts{m} ? "-M $opts{m} " : ""; # $opts{c} .= $opts{m}; # } # } # if($opts{u}) { # unless("$comms" eq "telnet") { # $opts{u} = $opts{u} ? "-l $opts{u} " : ""; # $opts{c} .= $opts{u}; # } # } # if("$comms" eq "telnet") { # $command .= "$opts{s} $opts{p}"; # } else { # if ($opts{p}) { # $opts{c} .= "-p $opts{p} $opts{s}"; # } else { # $opts{c} .= "$opts{s}"; # } # } # #$command .= " $command || sleep 5"; # warn("Running:$command\n"); # for debug purposes # exec($command); # }; 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"; warn("Running:\$command\\n"); # for debug purposes 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-2010 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; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/Host.pm��������������������������������������������������������������������������0000664�0000000�0000000�00000023134�12266174147�0015633�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������package App::ClusterSSH::Host; use strict; use warnings; use version; our $VERSION = version->new('0.03'); use Carp; 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 /) { 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_givenname { my ($self) = @_; return $self->{hostname}; } sub get_hostname { my ($self) = @_; return $self->{hostname}; } sub get_username { my ($self) = @_; return $self->{username} || 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 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->{type} && $self->{type} eq 'name' ) { if ( $ssh_hostname_for{ $self->{hostname} } ) { $self->{realname} = $self->{hostname}; } else { my $gethost_obj = gethostbyname( $self->{hostname} ); $self->{realname} = defined($gethost_obj) ? $gethost_obj->name() : $self->{hostname}; } } else { $self->{realname} = $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) \z }xms ) { $self->debug( 5, $self->loc( 'bracketed IPv6: u=[_1] h=[_2] p=[_3]', $1, $2, $3 ), ); return __PACKAGE__->new( parse_string => $parse_string, username => $1, hostname => $2, port => $3, 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) \z }xms ) { $self->debug( 5, $self->loc( 'std IPv4: u=[_1] h=[_2] p=[_3]', $1, $2, $3 ), ); return __PACKAGE__->new( parse_string => $parse_string, username => $1, hostname => $2, port => $3, type => 'ipv4', ); } # Check for unbracketed IPv6 addresses as best we can... # first, see if there is a username to grab my $username = q[]; if ( $host_string =~ s/\A(?:(.*)@)// ) { # catch where @ is in host_string but no text before it $username = $1 || q{}; } # 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 # also catch localhost address here if ( $colon_count == 7 || $host_string eq '::1' ) { $self->debug( 5, $self->loc( 'IPv6: u=[_1] h=[_2] p=[_3]', $username, $host_string, '' ), ); return __PACKAGE__->new( parse_string => $parse_string, username => $username, hostname => $host_string, port => q{}, type => 'ipv6', ); } if ( $colon_count > 1 && $colon_count < 8 && $host_string =~ m/:(\d+)$/xsm ) { 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]', $username, $host_string, '' ) ); #warn "host_string=$host_string"; #warn "username=$username"; #warn $self->loc('some string to return'); #warn 'debug done, returning'; return __PACKAGE__->new( parse_string => $parse_string, username => $username, hostname => $host_string, port => q{}, type => 'ipv6', ); } else { my $port = q{}; if ( $host_string =~ s/:(\d+)$// ) { $port = $1; } my $hostname = $host_string; $self->debug( 5, $self->loc( 'Default parse u=[_1] h=[_2] p=[_3]', $username, $hostname, $port ) ); return __PACKAGE__->new( parse_string => $parse_string, username => $username, hostname => $hostname, port => $port, type => 'name', ); } # Due to above rules, we'll never get this far anyhow # 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 Return specific details about the host =item $host->set_username =item $host->set_port =item $host->set_master 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-2010 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; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/L10N.pm��������������������������������������������������������������������������0000664�0000000�0000000�00000002141�12266174147�0015363�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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-2010 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; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/L10N/����������������������������������������������������������������������������0000775�0000000�0000000�00000000000�12266174147�0015027�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������lib/App/ClusterSSH/L10N/en.pm�����������������������������������������������������������������������0000664�0000000�0000000�00000001706�12266174147�0015773�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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-2010 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; ����������������������������������������������������������t/��������������������������������������������������������������������������������������������������0000775�0000000�0000000�00000000000�12266174147�0011333�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/00-load.t�����������������������������������������������������������������������������������������0000664�0000000�0000000�00000000277�12266174147�0012662�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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"); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/01l10n.t������������������������������������������������������������������������������������������0000664�0000000�0000000�00000000413�12266174147�0012431�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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' ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/02base.t������������������������������������������������������������������������������������������0000664�0000000�0000000�00000014207�12266174147�0012600�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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' ); 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' ); done_testing(); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/10host.t������������������������������������������������������������������������������������������0000664�0000000�0000000�00000037634�12266174147�0012653�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; 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)' ); diag('Checking IPv4 type addresses') if ( $ENV{TEST_VERBOSE} ); $host = App::ClusterSSH::Host->new( hostname => 'hostname' ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'hostname set' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host->set_port(2323); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host->set_username('username'); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'hostname' ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'hostname set' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host->set_port(2323); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host->set_username('username'); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'hostname', port => 2323, ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'hostname set' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host->set_username('username'); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'hostname', username => 'username', ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'hostname set' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'hostname', 'realname set' ); $host->set_port(2323); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->new( hostname => 'hostname', username => 'username', port => 2323, ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); diag('Parsing IPv4 hostname') if ( $ENV{TEST_VERBOSE} ); $host = App::ClusterSSH::Host->parse_host_string('hostname'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = App::ClusterSSH::Host->parse_host_string('host%name'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'host%name', 'stringify works' ); is( $host->get_hostname, 'host%name', 'checking set works' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'host%name', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('hostname:2323'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = App::ClusterSSH::Host->parse_host_string('host%name:2323'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'host%name', 'stringify works' ); is( $host->get_hostname, 'host%name', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, 'host%name', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@hostname:2323'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = App::ClusterSSH::Host->parse_host_string('username@host%name:2323'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'host%name', 'stringify works' ); is( $host->get_hostname, 'host%name', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'host%name', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@hostname'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'hostname', 'stringify works' ); is( $host->get_hostname, 'hostname', 'checking set works' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'hostname', 'realname set' ); $host = App::ClusterSSH::Host->parse_host_string('username@host%name'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, 'host%name', 'stringify works' ); is( $host->get_hostname, 'host%name', 'checking set works' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, 'host%name', 'realname set' ); diag('Parsing IPv4 IP address') if ( $ENV{TEST_VERBOSE} ); $host = App::ClusterSSH::Host->parse_host_string('127.0.0.1'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '127.0.0.1', 'stringify works' ); is( $host->get_hostname, '127.0.0.1', 'checking set works' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '127.0.0.1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('127.0.0.1:2323'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '127.0.0.1', 'stringify works' ); is( $host->get_hostname, '127.0.0.1', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '127.0.0.1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@127.0.0.1:2323'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '127.0.0.1', 'stringify works' ); is( $host->get_hostname, '127.0.0.1', 'checking set works' ); is( $host->get_port, 2323, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, '127.0.0.1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@127.0.0.1'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '127.0.0.1', 'stringify works' ); is( $host->get_hostname, '127.0.0.1', 'checking set works' ); is( $host->get_port, q{}, 'checking set works' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, '127.0.0.1', 'realname set' ); diag('Checking IPv6 type addresses') if ( $ENV{TEST_VERBOSE} ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('::1'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '::1', 'stringify works' ); is( $host->get_hostname, '::1', 'checking set works' ); is( $host->get_port, q{}, 'port is unset' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '::1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@::1'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '::1', 'stringify works' ); is( $host->get_hostname, '::1', 'checking set works' ); is( $host->get_port, q{}, 'port is unset' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, '::1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('[::1]'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '::1', 'stringify works' ); is( $host->get_hostname, '::1', 'checking set works' ); is( $host->get_port, q{}, 'port is unset' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '::1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@[::1]'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '::1', 'stringify works' ); is( $host->get_hostname, '::1', 'checking set works' ); is( $host->get_port, q{}, 'port is unset' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, '::1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('[::1]:22'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '::1', 'stringify works' ); is( $host->get_hostname, '::1', 'checking set works' ); is( $host->get_port, 22, 'checking port set' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '::1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string('username@[::1]:22'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '::1', 'stringify works' ); is( $host->get_hostname, '::1', 'checking set works' ); is( $host->get_port, 22, 'checking port set' ); is( $host->get_username, 'username', 'username is set' ); is( $host->get_realname, '::1', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); $host = App::ClusterSSH::Host->parse_host_string( '2001:0db8:85a3:0000:0000:8a2e:0370:7334'); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '2001:0db8:85a3:0000:0000:8a2e:0370:7334', 'stringify works' ); is( $host->get_hostname, '2001:0db8:85a3:0000:0000:8a2e:0370:7334', 'checking set works' ); is( $host->get_port, q{}, 'port is unset' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '2001:0db8:85a3:0000:0000:8a2e:0370:7334', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); trap { $host = App::ClusterSSH::Host->parse_host_string( '2001:0db8:85a3::8a2e:0370:7334'); }; is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->die, undef, 'returned ok' ); isa_ok( $host, "App::ClusterSSH::Host" ); is( $host, '2001:0db8:85a3::8a2e:0370:7334', 'stringify works' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stderr =~ tr/\n//, 2, 'got correct number of print lines' ); like( $trap->stderr, qr/^Ambiguous host string: "2001:0db8:85a3::8a2e:0370:7334/, 'checking warning output' ); like( $trap->stderr, qr/Assuming you meant "\[2001:0db8:85a3::8a2e:0370:7334\]"?/, 'checking warning output' ); is( $host->get_hostname, '2001:0db8:85a3::8a2e:0370:7334', 'checking set works' ); is( $host->get_port, q{}, 'port is unset' ); is( $host->get_username, q{}, 'username is unset' ); is( $host->get_realname, '2001:0db8:85a3::8a2e:0370:7334', 'realname set' ); $host = undef; is( $host, undef, 'starting afresh' ); 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', ); 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' ); } #$host = undef; #is( $host, undef, ' starting afresh for ssh hostname checks ' ); # #trap { # $host = App::ClusterSSH::Host->new( hostname => ' ssh_text ', ssh_config => $Bin . ' / 10 host_ssh_config ' ); #}; #is( $trap->leaveby, ' return ', ' returned ok ' ); #is( $trap->die, undef, ' returned ok ' ); #isa_ok( $host, "App::ClusterSSH::Host" ); #is( $host, ' ssh_text ', ' stringify works ' ); #is( $host->check_ssh_hostname, 0, ' check_ssh_hostname ok '); # #$host = undef; #is( $host, undef, ' starting afresh for ssh hostname checks ' ); # #trap { # $host = App::ClusterSSH::Host->new( hostname => ' ssh_text ', ssh_config => $Bin . ' / 10 host_ssh_config ' ); #}; #is( $trap->leaveby, ' return ', ' returned ok ' ); #is( $trap->die, undef, ' returned ok ' ); #isa_ok( $host, "App::ClusterSSH::Host" ); #is( $host, ' ssh_text ', ' stringify works ' ); #is( $host->check_ssh_hostname, 0, ' check_ssh_hostname ok '); done_testing(); ����������������������������������������������������������������������������������������������������t/10host_ssh_config���������������������������������������������������������������������������������0000664�0000000�0000000�00000000172�12266174147�0014576�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������host server1 host server2 server3 server4 host server-5 host server5.domain.name host server-6.domain.name #host server7 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/15config.t����������������������������������������������������������������������������������������0000664�0000000�0000000�00000043315�12266174147�0013141�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; 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 => "Control-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 => "", 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, send_menu_xml_file => $ENV{HOME} . '/.csshrc_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, which('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, which('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, which('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 = something', $/; close($csshrc); $expected{terminal} = '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' ); 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} . '/.csshrc_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=Control-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{/.csshrc_send_menu 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 #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(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/15config.t.file1����������������������������������������������������������������������������������0000664�0000000�0000000�00000000213�12266174147�0014126�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������screen_reserve_top = 100 screen_reserve_bottom = 160 screen_reserve_left = 100 screen_reserve_right = 100 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/15config.t.file2����������������������������������������������������������������������������������0000664�0000000�0000000�00000000032�12266174147�0014126�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������missing=what rubbish=here ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/15config.t.file3����������������������������������������������������������������������������������0000664�0000000�0000000�00000002511�12266174147�0014133�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/20helper.t����������������������������������������������������������������������������������������0000664�0000000�0000000�00000001700�12266174147�0013137�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; 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; 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' ); #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' ); done_testing(); ����������������������������������������������������������������t/30cluster.cannot_read�����������������������������������������������������������������������������0000664�0000000�0000000�00000000027�12266174147�0015355�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#cannot read this file ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/30cluster.file1�����������������������������������������������������������������������������������0000664�0000000�0000000�00000000013�12266174147�0014073�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������tag1 host1 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/30cluster.file2�����������������������������������������������������������������������������������0000664�0000000�0000000�00000000120�12266174147�0014073�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# a comment tag1 host1 tag2 host2 #line wrapped tag3 host3 \ host4 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/30cluster.file3�����������������������������������������������������������������������������������0000664�0000000�0000000�00000000153�12266174147�0014102�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# a comment tag1 host1 tag2 host2 #line wrapped tag3 host3 \ host4 default host7 host8 host9 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/30cluster.t���������������������������������������������������������������������������������������0000664�0000000�0000000�00000012465�12266174147�0013354�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; 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; BEGIN { use_ok("App::ClusterSSH::Cluster") || BAIL_OUT('failed to use module'); } my $cluster1 = App::ClusterSSH::Cluster->new(); 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' ); # now checks against running an external command my @external_expected; @external_expected = $cluster1->get_external_clusters("$Bin/external_cluster_command"); is_deeply( \@external_expected, [], 'External command no args' ); @external_expected = $cluster1->get_external_clusters( "$Bin/external_cluster_command tag1 tag2"); is_deeply( \@external_expected, [qw/tag1 tag2 /], 'External command: 2 args passed through' ); @external_expected = $cluster1->get_external_clusters( "$Bin/external_cluster_command tag100"); is_deeply( \@external_expected, [qw/host100 /], 'External command: 1 tag expanded to one host' ); @external_expected = $cluster1->get_external_clusters( "$Bin/external_cluster_command 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( "$Bin/external_cluster_command 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( "$Bin/external_cluster_command -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( "$Bin/external_cluster_command -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' ); 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; } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/30cluster.tag1������������������������������������������������������������������������������������0000664�0000000�0000000�00000000262�12266174147�0013735�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/80clusterssh.t������������������������������������������������������������������������������������0000664�0000000�0000000�00000000531�12266174147�0014066�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; 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(); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������t/boilerplate.t�������������������������������������������������������������������������������������0000664�0000000�0000000�00000002370�12266174147�0014024�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!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'); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/external_cluster_command��������������������������������������������������������������������������0000775�0000000�0000000�00000001472�12266174147�0016346�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # # test script for proving external command for fetching tags works # use strict; use warnings; use Getopt::Std; my $opt = {}; getopts( 'qx', $opt ); # 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; } my %tag_lookup = ( tag100 => [qw/ host100 /], tag200 => [qw/ host200 host210 host205 /], tag300 => [qw/ host300 host350 host325 /], tag400 => [qw/ tag100 tag200 tag300 host400 host401 /], ); my @lookup = @ARGV; for (@lookup) { if ( $tag_lookup{$_} ) { push( @lookup, @{ $tag_lookup{$_} } ); $_ = ''; } } @lookup = grep { $_ !~ m/^$/ } sort @lookup; if (@lookup) { print "@lookup", $/; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/manifest.t����������������������������������������������������������������������������������������0000664�0000000�0000000�00000000575�12266174147�0013335�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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' ); �����������������������������������������������������������������������������������������������������������������������������������t/pod-coverage.t������������������������������������������������������������������������������������0000664�0000000�0000000�00000001053�12266174147�0014072�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������t/pod.t���������������������������������������������������������������������������������������������0000664�0000000�0000000�00000000350�12266174147�0012300�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!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(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������