"Fossies" - the Fresh Open Source Software Archive

Member "clusterssh-4.16/lib/App/ClusterSSH.pm" (20 Jun 2020, 15553 Bytes) of package /linux/privat/clusterssh-4.16.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "ClusterSSH.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 4.15_vs_4.16.

    1 use warnings;
    2 use strict;
    3 package App::ClusterSSH;
    4 
    5 # ABSTRACT: Cluster administration tool
    6 # ABSTRACT: Cluster administration tool
    7 
    8 use version; our $VERSION = version->new('4.16');
    9 
   10 =head1 SYNOPSIS
   11 
   12 There is nothing in this module for public consumption.  See documentation
   13 for F<cssh>, F<crsh>, F<ctel>, F<ccon>, or F<cscp> instead.
   14 
   15 =head1 DESCRIPTION
   16 
   17 This is the core for App::ClusterSSH.  You should probably look at L<cssh> 
   18 instead.
   19 
   20 =head1 SUBROUTINES/METHODS
   21 
   22 These methods are listed here to tidy up Pod::Coverage test reports but
   23 will most likely be moved into other modules.  There are some notes within 
   24 the code until this time.
   25 
   26 =over 2
   27 
   28 =cut
   29 
   30 use Carp qw/cluck :DEFAULT/;
   31 
   32 use base qw/ App::ClusterSSH::Base /;
   33 use App::ClusterSSH::Host;
   34 use App::ClusterSSH::Config;
   35 use App::ClusterSSH::Helper;
   36 use App::ClusterSSH::Cluster;
   37 use App::ClusterSSH::Getopt;
   38 use App::ClusterSSH::Window;
   39 
   40 use FindBin qw($Script);
   41 
   42 use POSIX ":sys_wait_h";
   43 use POSIX qw/:sys_wait_h strftime mkfifo/;
   44 use File::Temp qw/:POSIX/;
   45 use Fcntl;
   46 use File::Basename;
   47 use Net::hostent;
   48 use Sys::Hostname;
   49 use English;
   50 use Socket;
   51 use File::Path qw(make_path);
   52 
   53 # Notes on general order of processing
   54 #
   55 # parse cmd line options for extra config files
   56 # load system configuration files
   57 # load cfg files from options
   58 # overlay rest of cmd line args onto options
   59 # record all clusters
   60 # parse given tags/hostnames and resolve to connections
   61 # open terminals
   62 # optionally open console if required
   63 
   64 sub new {
   65     my ( $class, %args ) = @_;
   66 
   67     my $self = $class->SUPER::new(%args);
   68 
   69     $self->{cluster} = App::ClusterSSH::Cluster->new( parent => $self, );
   70     $self->{options} = App::ClusterSSH::Getopt->new( parent => $self, );
   71     $self->{config}  = App::ClusterSSH::Config->new( parent => $self, );
   72     $self->{helper}  = App::ClusterSSH::Helper->new( parent => $self, );
   73     $self->{window}  = App::ClusterSSH::Window->new( parent => $self, );
   74 
   75     $self->set_config( $self->config );
   76 
   77     # catch and reap any zombies
   78     $SIG{CHLD} = sub {
   79         my $kid;
   80         do {
   81             $kid = waitpid( -1, WNOHANG );
   82             $self->debug( 2, "REAPER currently returns: $kid" );
   83         } until ( $kid == -1 || $kid == 0 );
   84     };
   85 
   86     return $self;
   87 }
   88 
   89 sub config {
   90     my ($self) = @_;
   91     return $self->{config};
   92 }
   93 
   94 sub cluster {
   95     my ($self) = @_;
   96     return $self->{cluster};
   97 }
   98 
   99 sub helper {
  100     my ($self) = @_;
  101     return $self->{helper};
  102 }
  103 
  104 sub options {
  105     my ($self) = @_;
  106     return $self->{options};
  107 }
  108 
  109 sub getopts {
  110     my ($self) = @_;
  111     return $self->options->getopts;
  112 }
  113 
  114 sub add_option {
  115     my ( $self, %args ) = @_;
  116     return $self->{options}->add_option(%args);
  117 }
  118 
  119 sub window {
  120     my ($self) = @_;
  121     return $self->{window};
  122 }
  123 
  124 # Set up UTF-8 on STDOUT
  125 binmode STDOUT, ":utf8";
  126 
  127 #use bytes;
  128 
  129 ### all sub-routines ###
  130 
  131 # catch_all exit routine that should always be used
  132 sub exit_prog() {
  133     my ($self) = @_;
  134     $self->debug( 3, "Exiting via normal routine" );
  135 
  136     if ( $self->config->{external_command_pipe}
  137         && -e $self->config->{external_command_pipe} )
  138     {
  139         close( $self->{external_command_pipe_fh} )
  140             or warn(
  141             "Could not close pipe "
  142                 . $self->config->{external_command_pipe} . ": ",
  143             $!
  144             );
  145         $self->debug( 2, "Removing external command pipe" );
  146         unlink( $self->config->{external_command_pipe} )
  147             || warn "Could not unlink "
  148             . $self->config->{external_command_pipe}
  149             . ": ", $!;
  150     }
  151 
  152     $self->window->terminate_all_hosts;
  153 
  154     exit 0;
  155 }
  156 
  157 sub evaluate_commands {
  158     my ($self) = @_;
  159     my ( $return, $user, $port, $host );
  160 
  161     # break apart the given host string to check for user or port configs
  162     my $evaluate = $self->options->evaluate;
  163     print "{evaluate}=", $evaluate, "\n";
  164     $user = $1 if ( ${evaluate} =~ s/^(.*)@// );
  165     $port = $1 if ( ${evaluate} =~ s/:(\w+)$// );
  166     $host = ${evaluate};
  167 
  168     $user = $user ? "-l $user" : "";
  169     if ( $self->config->{comms} eq "telnet" ) {
  170         $port = $port ? " $port" : "";
  171     }
  172     else {
  173         $port = $port ? "-p $port" : "";
  174     }
  175 
  176     print STDERR "Testing terminal - running command:\n";
  177 
  178     my $command = "$^X -e 'print \"Base terminal test\n\"; sleep 2'";
  179 
  180     my $terminal_command = join( ' ',
  181         $self->config->{terminal},
  182         $self->config->{terminal_allow_send_events}, "-e " );
  183 
  184     my $run_command = "$terminal_command $command";
  185 
  186     print STDERR $run_command, $/;
  187 
  188     system($run_command);
  189     print STDERR "\nTesting comms - running command:\n";
  190 
  191     my $comms_command = join( ' ',
  192         $self->config->{ $self->config->{comms} },
  193         $self->config->{ $self->config->{comms} . "_args" } );
  194 
  195     if ( $self->config->{comms} eq "telnet" ) {
  196         $comms_command .= " $host $port";
  197     }
  198     else {
  199         $comms_command
  200             .= " $user $port $host hostname ; echo Got hostname via ssh; sleep 2";
  201     }
  202 
  203     print STDERR $comms_command, $/;
  204 
  205     system($comms_command);
  206 
  207     $run_command = "$terminal_command '$comms_command'";
  208     print STDERR $run_command, $/;
  209 
  210     system($run_command);
  211 
  212     $self->exit_prog;
  213 }
  214 
  215 sub resolve_names(@) {
  216     my ( $self, @servers ) = @_;
  217     $self->debug( 2, 'Resolving cluster names: started' );
  218 
  219     foreach (@servers) {
  220         my $dirty    = $_;
  221         my $username = q{};
  222         $self->debug( 3, 'Checking tag ', $_ );
  223 
  224         if ( $dirty =~ s/^(.*)@// ) {
  225             $username = $1;
  226         }
  227 
  228         my @tag_list = $self->cluster->get_tag($dirty);
  229 
  230         if (   $self->config->{use_all_a_records}
  231             && $dirty !~ m/^(\d{1,3}\.?){4}$/
  232             && !@tag_list )
  233         {
  234             my $hostobj = gethostbyname($dirty);
  235             if ( defined($hostobj) ) {
  236                 my @alladdrs = map { inet_ntoa($_) } @{ $hostobj->addr_list };
  237                 $self->cluster->register_tag( $dirty, @alladdrs );
  238                 if ( $#alladdrs > 0 ) {
  239                     $self->debug( 3, 'Expanded to ',
  240                         join( ' ', $self->cluster->get_tag($dirty) ) );
  241                     @tag_list = $self->cluster->get_tag($dirty);
  242                 }
  243                 else {
  244                     # don't expand if there is only one record found
  245                     $self->debug( 3, 'Only one A record' );
  246                 }
  247             }
  248         }
  249         if (@tag_list) {
  250             $self->debug( 3, '... it is a cluster' );
  251             foreach my $node (@tag_list) {
  252                 if ($username) {
  253                     $node =~ s/^(.*)@//;
  254                     $node = $username . '@' . $node;
  255                 }
  256                 push( @servers, $node );
  257             }
  258             $_ = q{};
  259         }
  260     }
  261 
  262     # now run everything through the external command, if one is defined
  263     if ( $self->config->{external_cluster_command} ) {
  264         $self->debug( 4, 'External cluster command defined' );
  265 
  266         # use a second array here in case of failure so previously worked
  267         # out entries are not lost
  268         my @new_servers;
  269         eval {
  270             @new_servers = $self->cluster->get_external_clusters(@servers);
  271         };
  272 
  273         if ($@) {
  274             warn $@, $/;
  275         }
  276         else {
  277             @servers = @new_servers;
  278         }
  279     }
  280 
  281     # now clean the array up
  282     @servers = grep { $_ !~ m/^$/ } @servers;
  283 
  284     if ( $self->config->{unique_servers} ) {
  285         $self->debug( 3, 'removing duplicate server names' );
  286         @servers = $self->remove_repeated_servers(@servers);
  287     }
  288 
  289     $self->debug( 3, 'leaving with ', $_ ) foreach (@servers);
  290     $self->debug( 2, 'Resolving cluster names: completed' );
  291     return (@servers);
  292 }
  293 
  294 sub remove_repeated_servers {
  295     my $self = shift;
  296     my %all  = ();
  297     @all{@_} = 1;
  298     return ( keys %all );
  299 }
  300 
  301 sub run {
  302     my ($self) = @_;
  303 
  304     $self->getopts;
  305 
  306 ### main ###
  307 
  308     $self->window->initialise;
  309 
  310     $self->debug( 2, "VERSION: ", $__PACKAGE__::VERSION );
  311 
  312     # only use ssh_args from options if config file ssh_args not set AND
  313     # options is not the default value otherwise the default options
  314     # value is used instead of the config file
  315     if ( $self->config->{comms} eq 'ssh' ) {
  316         if ( defined $self->config->{ssh_args} ) {
  317             if (   $self->options->options
  318                 && $self->options->options ne
  319                 $self->options->options_default )
  320             {
  321                 $self->config->{ssh_args} = $self->options->options;
  322             }
  323         }
  324         else {
  325             $self->config->{ssh_args} = $self->options->options
  326                 if ( $self->options->options );
  327         }
  328     }
  329 
  330     $self->config->{terminal_args} = $self->options->term_args
  331         if ( $self->options->term_args );
  332 
  333     if ( $self->config->{terminal_args} =~ /-class (\w+)/ ) {
  334         $self->config->{terminal_allow_send_events}
  335             = "-xrm '$1.VT100.allowSendEvents:true'";
  336     }
  337 
  338     $self->config->dump() if ( $self->options->dump_config );
  339 
  340     $self->evaluate_commands() if ( $self->options->evaluate );
  341 
  342     $self->window->get_font_size();
  343 
  344     $self->window->load_keyboard_map();
  345 
  346     # read in normal cluster files
  347     $self->config->{extra_cluster_file} .= ',' . $self->options->cluster_file
  348         if ( $self->options->cluster_file );
  349     $self->config->{extra_tag_file} .= ',' . $self->options->tag_file
  350         if ( $self->options->tag_file );
  351 
  352     $self->cluster->get_cluster_entries( split /,/,
  353         $self->config->{extra_cluster_file} || '' );
  354     $self->cluster->get_tag_entries( split /,/,
  355         $self->config->{extra_tag_file} || '' );
  356 
  357     my @servers;
  358 
  359     if ( defined $self->options->list ) {
  360         my $eol = $self->options->quiet ? ' ' : $/;
  361         my $tab = $self->options->quiet ? ''  : "\t";
  362         if ( !$self->options->list ) {
  363             print( 'Available cluster tags:', $/ )
  364                 unless ( $self->options->quiet );
  365             print $tab, $_, $eol
  366                 foreach ( sort( $self->cluster->list_tags ) );
  367 
  368             my @external_clusters = $self->cluster->list_external_clusters;
  369             if (@external_clusters) {
  370                 print( 'Available external command tags:', $/ )
  371                     unless ( $self->options->quiet );
  372                 print $tab, $_, $eol foreach ( sort(@external_clusters) );
  373                 print $/;
  374             }
  375         }
  376         else {
  377             print 'Tag resolved to hosts: ', $/
  378                 unless ( $self->options->quiet );
  379             @servers = $self->resolve_names( $self->options->list );
  380 
  381             foreach my $svr (@servers) {
  382                 print $tab, $svr, $eol;
  383             }
  384             print $/;
  385         }
  386 
  387         $self->debug(
  388             4,
  389             "Full clusters dump: ",
  390             $self->_dump_args_hash( $self->cluster->dump_tags )
  391         );
  392         $self->exit_prog();
  393     }
  394 
  395     if (@ARGV) {
  396         @servers = $self->resolve_names(@ARGV);
  397     }
  398     else {
  399 
  400         #if ( my @default = $self->cluster->get_tag('default') ) {
  401         if ( $self->cluster->get_tag('default') ) {
  402             @servers
  403 
  404                 #    = $self->resolve_names( @default );
  405                 = $self->resolve_names( $self->cluster->get_tag('default') );
  406         }
  407     }
  408 
  409     $self->window->create_windows();
  410     $self->window->create_menubar();
  411 
  412     $self->window->change_main_window_title();
  413 
  414     $self->debug( 2, "Capture map events" );
  415     $self->window->capture_map_events();
  416 
  417     $self->debug( 0, 'Opening to: ', join( ' ', @servers ) )
  418         if ( @servers && !$self->options->quiet );
  419     $self->window->open_client_windows(@servers);
  420 
  421     # Check here if we are tiling windows.  Here instead of in func so
  422     # can be tiled from console window if wanted
  423     if ( $self->config->{window_tiling} eq "yes" ) {
  424         $self->window->retile_hosts();
  425     }
  426     else {
  427         $self->window->show_console();
  428     }
  429 
  430     $self->window->build_hosts_menu();
  431 
  432     $self->debug( 2, "Sleeping for a mo" );
  433     select( undef, undef, undef, 0.5 );
  434 
  435     $self->window->console_focus;
  436 
  437     # set up external command pipe
  438     if ( $self->config->{external_command_pipe} ) {
  439 
  440         if ( -e $self->config->{external_command_pipe} ) {
  441             $self->debug( 1, "Removing pre-existing external command pipe" );
  442             unlink( $self->config->{external_command_pipe} )
  443                 or die(
  444                 "Could not remove "
  445                     . $self->config->{external_command_pipe}
  446                     . " prior to creation: "
  447                     . $!,
  448                 $/
  449                 );
  450         }
  451 
  452         $self->debug( 2, "Creating external command pipe" );
  453 
  454         mkfifo(
  455             $self->config->{external_command_pipe},
  456             oct( $self->config->{external_command_mode} )
  457             )
  458             or die(
  459             "Could not create "
  460                 . $self->config->{external_command_pipe} . ": ",
  461             $!
  462             );
  463 
  464         sysopen(
  465             $self->{external_command_pipe_fh},
  466             $self->config->{external_command_pipe},
  467             O_NONBLOCK | O_RDONLY
  468             )
  469             or die(
  470             "Could not open " . $self->config->{external_command_pipe} . ": ",
  471             $!
  472             );
  473     }
  474 
  475     $self->debug( 2, "Setting up repeat" );
  476     $self->window->setup_repeat();
  477 
  478     # Start event loop
  479     $self->debug( 2, "Starting MainLoop" );
  480     $self->window->mainloop();
  481 
  482     # make sure we leave program in an expected way
  483     $self->exit_prog();
  484 }
  485 
  486 1;
  487 
  488 
  489 =item REAPER
  490 
  491 =item add_host_by_name
  492 
  493 =item add_option
  494 
  495 =item build_hosts_menu
  496 
  497 =item capture_map_events
  498 
  499 =item capture_terminal
  500 
  501 =item change_main_window_title
  502 
  503 =item close_inactive_sessions
  504 
  505 =item config
  506 
  507 =item helper
  508 
  509 =item cluster
  510 
  511 =item create_menubar
  512 
  513 =item create_windows
  514 
  515 =item dump_config
  516 
  517 =item getopts
  518 
  519 =item list_tags
  520 
  521 =item evaluate_commands
  522 
  523 =item exit_prog
  524 
  525 =item get_clusters
  526 
  527 =item get_font_size
  528 
  529 =item get_keycode_state
  530 
  531 =item key_event
  532 
  533 =item load_config_defaults
  534 
  535 =item load_configfile
  536 
  537 =item load_keyboard_map
  538 
  539 =item new
  540 
  541 =item open_client_windows
  542 
  543 =item options
  544 
  545 =item parse_config_file
  546 
  547 =item pick_color
  548 
  549 =item populate_send_menu
  550 
  551 =item populate_send_menu_entries_from_xml
  552 
  553 =item re_add_closed_sessions
  554 
  555 =item remove_repeated_servers
  556 
  557 =item resolve_names
  558 
  559 =item slash_slash_equal
  560 
  561 An implementation of the //= operator that works on older Perls.
  562 slash_slash_equal($a, 0) is equivalent to $a //= 0
  563 
  564 =item retile_hosts
  565 
  566 =item run
  567 
  568 =item send_resizemove
  569 
  570 =item send_text
  571 
  572 =item send_text_to_all_servers
  573 
  574 =item set_all_active
  575 
  576 =item set_half_inactive
  577 
  578 =item setup_repeat
  579 
  580 =item send_variable_text_to_all_servers
  581 
  582 =item show_console
  583 
  584 =item show_history
  585 
  586 =item substitute_macros
  587 
  588 =item terminate_host
  589 
  590 =item toggle_active_state
  591 
  592 =item update_display_text
  593 
  594 =item window
  595 
  596 Method to access assosiated window module
  597 
  598 =item write_default_user_config
  599                                            
  600 =back
  601 
  602 =head1 BUGS
  603 
  604 Please report any bugs or feature requests via L<https://github.com/duncs/clusterssh/issues>. 
  605 
  606 =head1 SUPPORT
  607 
  608 You can find documentation for this module with the perldoc command.
  609 
  610     perldoc App::ClusterSSH
  611 
  612 You can also look for information at:
  613 
  614 =over 4
  615 
  616 =item * Github issue tracker
  617 
  618 L<https://github.com/duncs/clusterssh/issues>
  619 
  620 =item * AnnoCPAN: Annotated CPAN documentation
  621 
  622 L<http://annocpan.org/dist/App-ClusterSSH>
  623 
  624 =item * CPAN Ratings
  625 
  626 L<http://cpanratings.perl.org/d/App-ClusterSSH>
  627 
  628 =item * Search CPAN
  629 
  630 L<http://search.cpan.org/dist/App-ClusterSSH/>
  631 
  632 =back
  633 
  634 =head1 ACKNOWLEDGEMENTS
  635 
  636 Please see the THANKS file from the original distribution.
  637 
  638 =cut