App-ClusterSSH

 view release on metacpan or  search on metacpan

lib/App/ClusterSSH.pm  view on Meta::CPAN

            if ( $self->config->{terminal_bg_style} eq 'dark' ) {
                $color = "-bg \\#000000 -fg $c";
            }
            else {
                $color = "-fg \\#000000 -bg $c";
            }
        }

        my $count = q{};
        while ( defined( $servers{ $server . q{ } . $count } ) ) {
            $count++;
        }
        $server .= q{ } . $count;

        $servers{$server}{connect_string} = $_;
        $servers{$server}{givenname}      = $given_server_name;
        $servers{$server}{realname}       = $realname;
        $servers{$server}{username}       = $self->config->{user};
        $servers{$server}{username}       = $username if ($username);
        $servers{$server}{username}       = $username || '';
        $servers{$server}{port}           = $port || '';
        $servers{$server}{master}         = $self->config->{mstr} || '';
        $servers{$server}{master}         = $master if ($master);

        $self->debug( 2, "Working on server $server for $_" );

        $servers{$server}{pipenm} = tmpnam();

        $self->debug( 2, "Set temp name to: $servers{$server}{pipenm}" );
        mkfifo( $servers{$server}{pipenm}, 0600 )
            or die("Cannot create pipe: $!");

       # NOTE: the PID is re-fetched from the xterm window (via helper_script)
       # later as it changes and we need an accurate PID as it is widely used
        $servers{$server}{pid} = fork();
        if ( !defined( $servers{$server}{pid} ) ) {
            die("Could not fork: $!");
        }

        if ( $servers{$server}{pid} == 0 ) {

          # this is the child
          # Since this is the child, we can mark any server unresolved without
          # affecting the main program
            $servers{$server}{realname} .= "==" if ( !$realname );

            # copy and amend the config provided to the helper script
            my $local_config = $self->config;
            $local_config->{command} = $self->substitute_macros( $server,
                $local_config->{command} );

            my $exec = join( ' ',
                $self->config->{terminal},
                $color,
                $self->config->{terminal_args},
                $self->config->{terminal_allow_send_events},
                $self->config->{terminal_title_opt},
                "'"
                    . $self->config->{title} . ': '
                    . $servers{$server}{connect_string} . "'",
                '-font ' . $self->config->{terminal_font},
                "-e " . $^X . ' -e ',
                "'" . $self->helper->script( $self->config ) . "'",
                " " . $servers{$server}{pipenm},
                " " . $servers{$server}{givenname},
                " '" . $servers{$server}{username} . "'",
                " '" . $servers{$server}{port} . "'",
                " '" . $servers{$server}{master} . "'",
            );
            $self->debug( 2, "Terminal exec line:\n$exec\n" );
            exec($exec) == 0 or warn("Failed: $!");
        }
    }

    # Now all the windows are open, get all their window IDs
    foreach my $server ( keys(%servers) ) {
        next if ( defined( $servers{$server}{active} ) );

        # sleep for a moment to give system time to come up
        select( undef, undef, undef, 0.1 );

        # block on open so we get the text when it comes in
        unless (
            sysopen(
                $servers{$server}{pipehl}, $servers{$server}{pipenm},
                O_RDONLY
            )
            )
        {
            warn(
                "Cannot open pipe for reading when talking to $server: $!\n");
        }
        else {

            # NOTE: read both the xterm pid and the window ID here
            # get PID here as it changes from the fork above, and we need the
            # correct PID
            $self->debug( 2, "Performing sysread" );
            my $piperead;
            sysread( $servers{$server}{pipehl}, $piperead, 100 );
            ( $servers{$server}{pid}, $servers{$server}{wid} )
                = split( /:/, $piperead, 2 );
            warn("Cannot determ pid of '$server' window\n")
                unless $servers{$server}{pid};
            warn("Cannot determ window ID of '$server' window\n")
                unless $servers{$server}{wid};
            $self->debug( 2, "Done and closing pipe" );

            close( $servers{$server}{pipehl} );
        }
        delete( $servers{$server}{pipehl} );

        unlink( $servers{$server}{pipenm} );
        delete( $servers{$server}{pipenm} );

        $servers{$server}{active} = 1;    # mark as active
        $self->config->{internal_activate_autoquit}
            = 1;                          # activate auto_quit if in use
    }
    $self->debug( 2, "All client windows opened" );
    $self->config->{internal_total} = int( keys(%servers) );

    return $self;
}

sub get_font_size() {
    my ($self) = @_;
    $self->debug( 2, "Fetching font size" );

    # get atom name<->number relations
    my $quad_width = $xdisplay->atom("QUAD_WIDTH");
    my $pixel_size = $xdisplay->atom("PIXEL_SIZE");

    my $font          = $xdisplay->new_rsrc;
    my $terminal_font = $self->config->{terminal_font};
    $xdisplay->OpenFont( $font, $terminal_font );

    my %font_info;

    eval { (%font_info) = $xdisplay->QueryFont($font); }
        || die( "Fatal: Unrecognised font used ($terminal_font).\n"
            . "Please amend \$HOME/.clusterssh/config with a valid font (see man page).\n"
        );

    $self->config->{internal_font_width}
        = $font_info{properties}{$quad_width};
    $self->config->{internal_font_height}
        = $font_info{properties}{$pixel_size};

    if (   !$self->config->{internal_font_width}
        || !$self->config->{internal_font_height} )
    {
        die(      "Fatal: Unrecognised font used ($terminal_font).\n"
                . "Please amend \$HOME/.clusterssh/config with a valid font (see man page).\n"
        );
    }

    $self->debug( 2, "Done with font size" );
    return $self;
}

sub show_console() {
    my ($self) = shift;
    $self->debug( 2, "Sending console to front" );

    $self->config->{internal_previous_state} = "mid-change";

    # fudge the counter to drop a redraw event;
    $self->config->{internal_map_count} -= 4;

    $xdisplay->flush();
    $windows{main_window}->update();

    select( undef, undef, undef, 0.2 );    #sleep for a mo
    $windows{main_window}->withdraw
        if $windows{main_window}->state ne "withdrawn";

    # 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;
}

# set the first argument to the second if the first is undefined
# the equivalent of //= but works in older Perls (e.g. 5.8)
sub slash_slash_equal(\$$) {

    if ( !defined( ${ $_[0] } ) ) {
        ${ $_[0] } = $_[1];
    }

    return ${ $_[0] };
}

# leave function def open here so we can be flexible in how it's called
sub retile_hosts {
    my ( $self, $force ) = @_;
    $force ||= "";
    $self->debug( 2, "Retiling windows" );

    my %config;

    if ( $self->config->{window_tiling} ne "yes" && !$force ) {
        $self->debug( 3,
            "Not meant to be tiling; just reshow windows as they were" );

        foreach my $server ( reverse( keys(%servers) ) ) {
            $xdisplay->req( 'MapWindow', $servers{$server}{wid} );
        }
        $xdisplay->flush();
        $self->show_console();
        return;
    }

    # ALL SIZES SHOULD BE IN PIXELS for consistency

    $self->debug( 2, "Count is currently ", $self->config->{internal_total} );

    if ( $self->config->{internal_total} == 0 ) {

        # If nothing to tile, don't bother doing anything, just show console
        return $self->show_console();
    }

    # work out terminal pixel size from terminal size & font size
    # does not include any title bars or scroll bars - purely text area
    $self->config->{internal_terminal_cols}
        = ( $self->config->{terminal_size} =~ /(\d+)x.*/ )[0];
    $self->config->{internal_terminal_width}
        = (   $self->config->{internal_terminal_cols}
            * $self->config->{internal_font_width} )
        + $self->config->{terminal_decoration_width};

    $self->config->{internal_terminal_rows}
        = ( $self->config->{terminal_size} =~ /.*x(\d+)/ )[0];
    $self->config->{internal_terminal_height}
        = (   $self->config->{internal_terminal_rows}
            * $self->config->{internal_font_height} )
        + $self->config->{terminal_decoration_height};

    # fetch screen size
    $self->config->{internal_screen_height} = $xdisplay->{height_in_pixels};
    $self->config->{internal_screen_width}  = $xdisplay->{width_in_pixels};

    # Now, work out how many columns of terminals we can fit on screen
    if ( $self->config->{rows} != -1 || $self->config->{cols} != -1 ) {
        if ( $self->config->{rows} != -1 ) {
            $self->config->{internal_rows}    = $self->config->{rows};
            $self->config->{internal_columns} = int(
                (         $self->config->{internal_total}
                        / $self->config->{internal_rows}
                ) + 0.999
            );
        }
        else {
            $self->config->{internal_columns} = $self->config->{cols};
            $self->config->{internal_rows}    = int(
                (         $self->config->{internal_total}
                        / $self->config->{internal_columns}
                ) + 0.999
            );
        }
    }
    else {
        $self->config->{internal_columns} = int(
            (         $self->config->{internal_screen_width}
                    - $self->config->{screen_reserve_left}
                    - $self->config->{screen_reserve_right}
            ) / (
                $self->config->{internal_terminal_width}
                    + $self->config->{terminal_reserve_left}
                    + $self->config->{terminal_reserve_right}
            )
        );

      # Work out the number of rows we need to use to fit everything on screen
        $self->config->{internal_rows} = int(
            (         $self->config->{internal_total}
                    / $self->config->{internal_columns}
            ) + 0.999
        );
    }
    $self->debug( 2, "Screen Columns: ", $self->config->{internal_columns} );
    $self->debug( 2, "Screen Rows: ",    $self->config->{internal_rows} );
    $self->debug( 2, "Fill scree: ",     $self->config->{fillscreen} );

    # Now adjust the height of the terminal to either the max given,
    # or to get everything on screen
    if ( $self->config->{fillscreen} ne 'yes' ) {
        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}
                    )

lib/App/ClusterSSH.pm  view on Meta::CPAN

    if ( $self->config->{show_history} ) {
        $windows{history}->pack(
            -fill   => "x",
            -expand => 1,
        );
    }

    $windows{main_window}->bind( '<Destroy>' => sub { $self->exit_prog } );

    # remove all Paste events so we set them up cleanly
    $windows{main_window}->eventDelete('<<Paste>>');

    # Set up paste events from scratch
    if ( $self->config->{key_paste} && $self->config->{key_paste} ne "null" )
    {
        $windows{main_window}->eventAdd(
            '<<Paste>>' => '<' . $self->config->{key_paste} . '>' );
    }

    if (   $self->config->{mouse_paste}
        && $self->config->{mouse_paste} ne "null" )
    {
        $windows{main_window}->eventAdd(
            '<<Paste>>' => '<' . $self->config->{mouse_paste} . '>' );
    }

    $windows{main_window}->bind(
        '<<Paste>>' => sub {
            $self->debug( 2, "PASTE EVENT" );

            $menus{entrytext} = "";
            my $paste_text = '';

            # SelectionGet is fatal if no selection is given
            Tk::catch {
                $paste_text = $windows{main_window}->SelectionGet;
            };

            if ( !length($paste_text) ) {
                warn("Got empty paste event\n");
                return;
            }

            $self->debug( 2, "Got text :", $paste_text, ":" );

            $self->update_display_text($paste_text);

            # now sent it on
            foreach my $svr ( keys(%servers) ) {
                $self->send_text( $svr, $paste_text )
                    if ( $servers{$svr}{active} == 1 );
            }
        }
    );

    $windows{help} = $windows{main_window}->Dialog(
        -popover    => $windows{main_window},
        -overanchor => "c",
        -popanchor  => "c",
        -class      => 'cssh',
        -font       => [
            -family => "interface system",
            -size   => 10,
        ],
        -text =>
            "Cluster Administrator Console using SSH\n\nVersion: $VERSION.\n\n"
            . "Bug/Suggestions to http://clusterssh.sf.net/",
    );

    $windows{manpage} = $windows{main_window}->DialogBox(
        -popanchor  => "c",
        -overanchor => "c",
        -title      => "Cssh Documentation",
        -buttons    => ['Close'],
        -class      => 'cssh',
    );

    my $manpage = `pod2text -l -q=\"\" $0 2>/dev/null`;
    if ( !$manpage ) {
        $manpage
            = "Help is missing.\nSee that command 'pod2text' is installed and in PATH.";
    }
    $windows{mantext}
        = $windows{manpage}->Scrolled( "Text", )->pack( -fill => 'both' );
    $windows{mantext}->insert( 'end', $manpage );
    $windows{mantext}->configure( -state => 'disabled' );

    $windows{addhost} = $windows{main_window}->DialogBox(
        -popover        => $windows{main_window},
        -popanchor      => 'n',
        -title          => "Add Host(s) or Cluster(s)",
        -buttons        => [ 'Add', 'Cancel' ],
        -default_button => 'Add',
        -class          => 'cssh',
    );

    my @tags = $self->cluster->list_tags();
    my @external_tags = map {"$_ *"} $self->cluster->list_external_clusters();
    push( @tags, @external_tags );

    if ( $self->config->{max_addhost_menu_cluster_items}
        && scalar @tags )
    {
        if ( scalar @tags < $self->config->{max_addhost_menu_cluster_items} )
        {
            $menus{listbox} = $windows{addhost}->Listbox(
                -selectmode => 'extended',
                -height     => scalar @tags,
                -class      => 'cssh',
            )->pack();
        }
        else {
            $menus{listbox} = $windows{addhost}->Scrolled(
                'Listbox',
                -scrollbars => 'e',
                -selectmode => 'extended',
                -height => $self->config->{max_addhost_menu_cluster_items},
                -class  => 'cssh',
            )->pack();
        }
        $menus{listbox}->insert( 'end', sort @tags );

lib/App/ClusterSSH.pm  view on Meta::CPAN

sub run {
    my ($self) = @_;

    $self->getopts;

### main ###

    # only get xdisplay if we got past usage and help stuff
    $xdisplay = X11::Protocol->new();

    if ( !$xdisplay ) {
        die("Failed to get X connection\n");
    }

    $self->debug( 2, "VERSION: $VERSION" );

    # only use ssh_args from options if config file ssh_args not set AND
    # options is not the default value otherwise the default options
    # value is used instead of the config file
    if ( $self->config->{comms} eq 'ssh' ) {
        if ( defined $self->config->{ssh_args} ) {
            if (   $self->options->options
                && $self->options->options ne
                $self->options->options_default )
            {
                $self->config->{ssh_args} = $self->options->options;
            }
        }
        else {
            $self->config->{ssh_args} = $self->options->options
                if ( $self->options->options );
        }
    }

    $self->config->{terminal_args} = $self->options->term_args
        if ( $self->options->term_args );

    if ( $self->config->{terminal_args} =~ /-class (\w+)/ ) {
        $self->config->{terminal_allow_send_events}
            = "-xrm '$1.VT100.allowSendEvents:true'";
    }

    # if the user has asked for natural sorting we need to include an extra
    # module
    if ( $self->config()->{'use_natural_sort'} ) {
        eval { Module::Load::load('Sort::Naturally'); };
        if ($@) {
            warn(
                "natural sorting requested but unable to load Sort::Naturally: $@\n"
            );
        }
        else {
            $sort = sub { Sort::Naturally::nsort(@_) };
        }
    }

    $self->config->dump() if ( $self->options->dump_config );

    $self->evaluate_commands() if ( $self->options->evaluate );

    $self->get_font_size();

    $self->load_keyboard_map();

    # read in normal cluster files
    $self->config->{extra_cluster_file} .= ',' . $self->options->cluster_file
        if ( $self->options->cluster_file );
    $self->config->{extra_tag_file} .= ',' . $self->options->tag_file
        if ( $self->options->tag_file );

    $self->cluster->get_cluster_entries( split /,/,
        $self->config->{extra_cluster_file} || '' );
    $self->cluster->get_tag_entries( split /,/,
        $self->config->{extra_tag_file} || '' );

    if ( defined $self->options->list ) {
        my $eol = $self->options->quiet ? ' ' : $/;
        my $tab = $self->options->quiet ? ''  : "\t";
        if ( !$self->options->list ) {
            print( 'Available cluster tags:', $/ )
                unless ( $self->options->quiet );
            print $tab, $_, $eol
                foreach ( sort( $self->cluster->list_tags ) );

            my @external_clusters = $self->cluster->list_external_clusters;
            if (@external_clusters) {
                print( 'Available external command tags:', $/ )
                    unless ( $self->options->quiet );
                print $tab, $_, $eol foreach ( sort(@external_clusters) );
                print $/;
            }
        }
        else {
            print 'Tag resolved to hosts: ', $/
                unless ( $self->options->quiet );
            @servers = $self->resolve_names( $self->options->list );

            foreach my $svr (@servers) {
                print $tab, $svr, $eol;
            }
            print $/;
        }

        $self->debug(
            4,
            "Full clusters dump: ",
            $self->_dump_args_hash( $self->cluster->dump_tags )
        );
        $self->exit_prog();
    }

    if (@ARGV) {
        @servers = $self->resolve_names(@ARGV);
    }
    else {

        #if ( my @default = $self->cluster->get_tag('default') ) {
        if ( $self->cluster->get_tag('default') ) {
            @servers

                #    = $self->resolve_names( @default );

lib/App/ClusterSSH.pm  view on Meta::CPAN

=head1 NAME

App::ClusterSSH - A container for functions of the ClusterSSH programs

=head1 SYNOPSIS

There is nothing in this module for public consumption.  See documentation
for F<cssh>, F<crsh>, F<ctel>, F<ccon>, or F<cscp> instead.

=head1 DESCRIPTION

This is the core for App::ClusterSSH.  You should probably look at L<cssh> 
instead.

=head1 SUBROUTINES/METHODS

These methods are listed here to tidy up Pod::Coverage test reports but
will most likely be moved into other modules.  There are some notes within 
the code until this time.

=over 2

=item REAPER

=item add_host_by_name

=item add_option

=item build_hosts_menu

=item capture_map_events

=item capture_terminal

=item change_main_window_title

=item close_inactive_sessions

=item config

=item helper

=item cluster

=item create_menubar

=item create_windows

=item dump_config

=item getopts

=item list_tags

=item evaluate_commands

=item exit_prog

=item get_clusters

=item get_font_size

=item get_keycode_state

=item key_event

=item load_config_defaults

=item load_configfile

=item load_keyboard_map

=item new

=item open_client_windows

=item options

=item parse_config_file

=item pick_color

=item populate_send_menu

=item populate_send_menu_entries_from_xml

=item re_add_closed_sessions

=item remove_repeated_servers

=item resolve_names

=item slash_slash_equal

An implementation of the //= operator that works on older Perls.
slash_slash_equal($a, 0) is equivalent to $a //= 0

=item retile_hosts

=item run

=item send_resizemove

=item send_text

=item send_text_to_all_servers

=item set_all_active

=item set_half_inactive

=item setup_repeat

=item send_variable_text_to_all_servers

=item show_console

=item show_history

=item substitute_macros