| #!/usr/bin/perl |
| # vim: set sw=4 ts=4 et : |
| |
| use strict; |
| use warnings; |
| |
| ## MAYBE set 'sane' PATH ?? |
| |
| $ENV{LANG} = 'C'; |
| $ENV{LC_ALL} = 'C'; |
| $ENV{LANGUAGE} = 'C'; |
| |
| #use Data::Dumper; |
| |
| # globals |
| my $PROC_DRBD = "/proc/drbd"; |
| my ($HOSTNAME) = (`uname -n` =~ /(\S+)/); |
| my $stderr_to_dev_null = 1; |
| my $watch = 0; |
| my %drbd; |
| my %minor_of_name; |
| my $DRBD_VERSION; |
| my @DRBD_VERSION; |
| |
| our $use_colors = (-t STDOUT) + 0; |
| |
| my %xen_info; |
| my %virsh_info; |
| |
| # sets $drbd{minor}->{name} (and possibly ->{ll_dev}) |
| sub map_minor_to_resource_names() |
| { |
| my @drbdadm_sh_status = `drbdadm sh-status`; |
| my ($ll_res, $ll_dev, $ll_minor, $conf_res, $conf_vnr, $minor, $name, $vnr); |
| |
| for (@drbdadm_sh_status) { |
| # volumes only present in >= 8.4 |
| # some things generated by drbdadm |
| |
| /^_conf_res_name=(.*)\n/ and $conf_res = $1, $name = $conf_res; |
| /^_conf_volume=(\d+)\n/ and $conf_vnr = $1; |
| |
| /^_stacked_on=(.*?)\n/ and $ll_res = $1; |
| # not always present: |
| /^_stacked_on_device=(.*)\n/ and $ll_dev = $1; |
| /^_stacked_on_minor=(\d+)\n/ and $ll_minor = $1; |
| |
| # rest generated by drbdsetup |
| /^_minor=(.*?)\n/ and $minor = $1; |
| /^_res_name=(.+?)\n/ and $name = $1; |
| /^_volume=(\d+)\n/ and $vnr = $1; |
| |
| /^_sh_status_process/ or next; |
| |
| $drbd{$minor}{name} = $name; |
| if (defined $conf_vnr) { |
| # >= 8.4, append /volume to resource name. |
| # If both are present, they should be the same. But |
| # just in case, prefer the kernel volume number, if it |
| # is present and positive. Else, use the volume number |
| # from the config. |
| $drbd{$minor}{name} .= defined $vnr ? "/$vnr" : "/$conf_vnr"; |
| } |
| $minor_of_name{$name} = $minor; |
| $drbd{$minor}{ll_dev} = defined($ll_dev) ? $ll_minor : $ll_res |
| if $ll_res; |
| } |
| |
| # fix up hack for git versions 8.3.1 > x > 8.3.0: |
| # _stacked_on_minor information is missing, |
| # _stacked_on is resource name |
| # may be defined (and reported) out of order. |
| for my $i (keys %drbd) { |
| next unless exists $drbd{$i}->{ll_dev}; |
| my $lower = $drbd{$i}->{ll_dev}; |
| next if $lower =~ /^\d+$/; |
| next unless exists $minor_of_name{$lower}; |
| $drbd{$i}->{ll_dev} = $minor_of_name{$lower}; |
| } |
| # fix up to be able to report "lower dev of:" |
| for my $i (keys %drbd) { |
| next unless exists $drbd{$i}->{ll_dev}; |
| my $lower = $drbd{$i}->{ll_dev}; |
| $drbd{$lower}->{ll_dev_of} = $i; |
| } |
| } |
| |
| sub ll_dev_info { |
| my $i = shift; |
| ( "ll-dev of:", $i, $drbd{$i}{name} ) |
| } |
| |
| # sets $drbd{minor}->{state} and (and possibly ->{sync}) |
| sub slurp_proc_drbd_or_exit() { |
| $_=<PD>; |
| my ($DRBD_VERSION) = /version: ([\d\.]+)/; |
| @DRBD_VERSION = split(/\./, $DRBD_VERSION); |
| my $minor; |
| while (defined($_ = <PD>)) { |
| chomp; |
| /^ *(\d+):/ and do { |
| # skip unconfigured devices |
| $minor = $1; |
| if (/^ *(\d+): cs:Unconfigured/) { |
| next |
| unless exists $drbd{$minor} |
| and exists $drbd{$minor}{name}; |
| } |
| my $uc = /Unconfigured/ ? "." : undef; |
| ($drbd{$minor}{conn}) = $uc || m{\bcs:(\w+)\b}; |
| ($drbd{$minor}{role}) = $uc || m{\bro:(\w+/\w+)\b}; |
| ($drbd{$minor}{dstate}) = $uc || m{\bds:(\w+/\w+)\b}; |
| }; |
| /^\t\[.*sync.ed:/ and do { |
| $drbd{$minor}{sync} = $_; |
| }; |
| /^\t[0-9 %]+oos:/ and do { |
| $drbd{$minor}{sync} = $_; |
| }; |
| } |
| close PD; |
| for (values %drbd) { |
| $_->{conn} ||= "Unconfigured"; |
| $_->{role} ||= "."; |
| $_->{dstate} ||= "."; |
| } |
| } |
| |
| our $ansi_color_re = qr{(\033\[[\d;]+?m)}; |
| |
| sub abbreviate { |
| my($w, $max) = @_; |
| |
| $max ||= 15; |
| |
| my $col_pre = ($w =~ s/^$ansi_color_re//o ) ? $1 : ""; |
| my $col_post = ($w =~ s/$ansi_color_re$//o) ? $1 : ""; |
| |
| # keep UPPERCase and a few lowercase characters. |
| # Make "Connecting" to "C'ing", to get it distinct from "Connected" |
| 1 while length($w) > $max && |
| ( $w =~ s/^(C)(onnecting)$/"$1'" . substr($2, 2-$max)/eg || # needs to cut 2 characters, because one is inserted again. |
| $w =~ s/([a-z]+)[a-z]/$1/g ); |
| |
| return $col_pre . substr($w, 0, $max) . $col_post; |
| } |
| |
| # taking a sorted list of keys and a hash, produce a short output. |
| # eg. Connected(*)/WFConnection(alice) |
| sub shorten_list { |
| my ($keys, $hash, $max) = @_; |
| my %vals; |
| my %vl; |
| |
| for my $k (@$keys) { |
| $vals{ $hash->{$k} }{ $k }++; |
| $vl{ $hash->{$k} }++; |
| } |
| |
| |
| # only a single value? Fine! |
| # return abbreviate($hash->{$keys->[0]}, 6) . "(*)" |
| return $hash->{$keys->[0]} . "(" . (values %vl)[0] . "*)" |
| if 1 == (keys %vals); |
| |
| # only 1 or 2 keys, ie. 2 values? Fine, done. |
| return join("/", map { abbreviate($hash->{$_}, 6); } @$keys) |
| if (@$keys <= 2); |
| |
| # get sorted counts. |
| my @v = sort { $b <=> $a; } values %vl; |
| |
| #print "=========", Dumper(\@v); |
| # use a wildcard if one element is 3 or more times used, and more often than every other. |
| my ($wc_data) = |
| (($v[0] >= 3) && ($v[0] != $v[1])) ? |
| grep($vl{$_} == $v[0], keys %vl) : (); |
| |
| my @stg; |
| my %done; |
| push(@stg, abbreviate($wc_data, 4) . "(" . $v[0] . "*)"), |
| $done{$wc_data}++ |
| if ($wc_data); |
| |
| for my $k2 (@$keys) { |
| my $v = $hash->{$k2}; |
| next if $done{$v}++; |
| |
| push @stg, abbreviate($v, 4) . |
| "(" . join(",", keys %{$vals{$v}} ) . ")"; |
| } |
| return join("/", @stg); |
| } |
| |
| sub slurp_drbdsetup() { |
| unless (open(DS,"drbdsetup events2 --now --statistics " . |
| ($use_colors ? "--color=always " : "") . |
| " |")) { |
| print "drbdsetup not started\n"; |
| exit 0; |
| } |
| |
| my(%later, $my_role); |
| while (<DS>) { |
| chomp; |
| next unless s/^exists //; |
| last if /^-$/; # EOD |
| s/^([\w.-]+) name:([\w.-]+) //; |
| my $what = $1; |
| my $res = $2; |
| my %f = map { split(/:/, $_, 2); } split(/ +/, $_); |
| |
| if ($what eq "resource" && |
| ($my_role = $f{'role'})) { |
| $later{$res}{peers}{states}{$HOSTNAME} = $my_role; |
| # local node is always connected |
| $later{$res}{peers}{conns}{$HOSTNAME} = "Connected"; |
| } elsif ($what eq "connection") { |
| my $p = $f{'conn-name'}; |
| my $cs= $f{'connection'}; |
| my $r = $f{'role'}; |
| # Increase difference between "Connecting" and "Connected" |
| $cs =~ s/^Connecting/'ing/; |
| $later{$res}{peers}{states}{$p} = $r; |
| $later{$res}{peers}{conns}{$p} = $cs; |
| $later{$res}{hosts}{$p}++; |
| } elsif ($what eq "device") { |
| my $minor = $f{minor}; |
| my $vol = $f{volume}; |
| $later{$res}{vol_minor}{$vol} = $minor; |
| $later{$res}{peers}{dstates}{$vol}{$HOSTNAME} = $f{disk}; |
| } elsif ($what eq "peer-device") { |
| my $n = $f{"conn-name"}; |
| my $vol = $f{volume}; |
| $later{$res}{peers}{dstates}{$vol}{$n} = $f{"peer-disk"}; |
| } else { |
| warn("unknown key $what\n"); |
| } |
| } |
| |
| |
| for my $res2 (keys %later) { |
| my @h = sort keys %{$later{$res2}{hosts}}; |
| my @h_incl = ($HOSTNAME, @h); |
| my $vol_minor = $later{$res2}{vol_minor}; |
| my $peers = $later{$res2}{peers}; |
| |
| for my $vol2 (keys %$vol_minor) { |
| my $minor2 = $vol_minor->{$vol2}; |
| |
| my $name = length($vol2) ? "$res2/$vol2" : $res2; |
| # create hash |
| $drbd{$minor2}{name} = $name; |
| my $v = $drbd{$minor2}; |
| |
| |
| # role with local=first |
| $v->{role} = join("/", $my_role, |
| shorten_list(\@h, $peers->{states})); |
| # role with all mixed together |
| $v->{role} = shorten_list(\@h_incl, $peers->{states}); |
| |
| $v->{dstate} = shorten_list(\@h_incl, $peers->{dstates}{$vol2}); |
| $v->{conn} = shorten_list(\@h_incl, $peers->{conns}); |
| } |
| } |
| |
| close DS; |
| } |
| |
| |
| # sets $drbd{minor}->{pv_info} |
| sub get_pv_info() |
| { |
| for (`pvs --noheadings --units g -o pv_name,vg_name,pv_size,pv_used`) { |
| m{^\s*/dev/drbd(\d+)\s+(\S+)\s+(\S+)\s+(\S+)\s*$} or next; |
| # PV VG PSize Used |
| $drbd{$1}{pv_info} = { vg => $2, size => $3, used => $4 }; |
| } |
| } |
| |
| sub pv_info |
| { |
| my $t = shift; |
| "lvm-pv:", @{$t}{qw(vg size used)}; |
| } |
| |
| # sets $drbd{minor}->{df_info} |
| sub get_df_info() |
| { |
| for (`df -TPhl -x tmpfs --local`) { |
| # Filesystem Type Size Used Avail Use% Mounted on |
| m{^/dev/drbd(\d+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)} or next; |
| $drbd{$1}{df_info} = { type => $2, size => $3, used => $4, |
| avail => $5, use_percent => $6, mountpoint => $7 }; |
| } |
| } |
| |
| sub df_info |
| { |
| my $t = shift; |
| @{$t}{qw(mountpoint type size used avail use_percent)}; |
| } |
| |
| sub get_swap_info() |
| { |
| open(my $fd, "< /proc/swaps") or return; |
| while (<$fd>) { |
| # Filename Type Size Used Priority |
| # /dev/drbd100 partition 262140 0 -1 |
| m{^/dev/drbd(\d+)\s+(\S+)\s+(\d+)\s+(\d+)} or next; |
| $drbd{$1}{df_info} = { type => 'swap', size => $3, used => $4, }; |
| } |
| } |
| |
| # sets $drbd{minor}->{xen_info} |
| sub get_xen_info() |
| { |
| my $dom; |
| my $running = 0; |
| my %i; |
| for (`xm list --long`) { |
| /^\s+\(name ([^)\n]+)\)/ and $dom = $1; |
| /drbd:([^)\n]+)/ and $i{$minor_of_name{$1}}++; |
| m{phy:/dev/drbd(\d+)} and $i{$1}++; |
| /^\s+\(state r/ and $running = 1; |
| if (/^\)$/) { |
| for (keys %i) { |
| $drbd{$_}{xen_info} = |
| $running ? |
| "\*$dom" : "_$dom"; |
| } |
| $running = 0; |
| %i = (); |
| } |
| } |
| } |
| |
| # set $drbd{minor}->{virsh_info} |
| sub get_virsh_info() |
| { |
| local $/ = undef; |
| my $virsh_list = `virsh list --all`; |
| # Id Name State |
| # ---------------------------------- |
| # 1 mail running |
| # 2 support running |
| # - debian-master shut off |
| # - www shut off |
| |
| my %info; |
| my $virsh_dumpxml; |
| my $pid; |
| |
| $virsh_list =~ s/^\s+Id\s+Name\s+?State\s*-+\n//; |
| while ($virsh_list =~ m{^\s*(\S+)\s+(\S+)\s+(\S.*?)\n}gm) { |
| $info{$2} = { id => $1, name => $2, state => $3 }; |
| # print STDERR "$1, $2, $3\n"; |
| } |
| for my $dom (keys %info) { |
| # add error processing as above |
| $pid = open(V, "-|"); |
| return unless defined $pid; |
| |
| if ($pid == 0) { # child |
| exec("virsh", "dumpxml", $dom) |
| or die "can't exec program: $!"; |
| # NOTREACHED |
| } |
| |
| # parent |
| $_ = <V>; |
| close(V) or warn "virsh dumpxml exit code: $?\n"; |
| for (m{<disk\ [^>]*>.*?</disk>}gs) { |
| m{<source\ (?:dev|file)='/dev/drbd([^']+)'/>} or next; |
| my $dev = $1; |
| if ($dev !~ /^\d+$/) { |
| my @stat = stat("/dev/drbd$dev") or next; |
| $dev = $stat[6] & 0xff; |
| } |
| m{<target\ dev='([^']*)'\s+bus='([^']*)'}xg; |
| $drbd{$dev}{virsh_info} = { |
| domname => |
| $info{$dom}->{state} eq 'running' ? |
| "\*$dom" : "_$dom", |
| vdev => $1, |
| bus => $2, |
| }; |
| } |
| } |
| } |
| |
| sub virsh_info |
| { |
| my $t = shift; |
| @{$t}{qw(domname vdev bus)}; |
| } |
| |
| # first, for debugging of this script and its regex'es, |
| # allow reading from a prepared file instead of /proc/drbd |
| # Getopt::Long is standard since quite some time, but in case it's not available somewhere we'll fail soft. |
| eval { |
| use Getopt::Long; |
| |
| GetOptions( |
| "proc-drbd=s" => \$PROC_DRBD, |
| "stderr-to-dev-null|d" => \$stderr_to_dev_null, |
| "color|colors|c:s" => \$use_colors) or |
| die "Unknown command line argument.\n"; |
| |
| $use_colors = 0 if $use_colors =~ m/^(never|no|off)$/; |
| $use_colors = 1 if $use_colors =~ m/^(always|yes|on)$/; |
| warn "unrecognized value for --color" unless $use_colors =~ /^[01]$/; |
| }; |
| |
| print STDERR "NOTE: drbd-overview will be deprecated soon.\nPlease consider using drbdtop.\n\n"; |
| |
| open STDERR, "/dev/null" |
| if $stderr_to_dev_null; |
| |
| unless (open(PD,$PROC_DRBD)) { |
| print "drbd not loaded\n"; |
| exit 0; |
| } |
| |
| map_minor_to_resource_names; |
| slurp_proc_drbd_or_exit; |
| |
| slurp_drbdsetup if $DRBD_VERSION[0] >= 9; |
| |
| get_pv_info; |
| get_df_info; |
| get_swap_info; |
| get_xen_info; |
| get_virsh_info; |
| |
| |
| # generate output, adjust columns |
| my @out = []; |
| my @out_plain = []; |
| my @maxw = (); |
| my $line = 0; |
| |
| my @minors_sorted = sort { $a <=> $b } keys %drbd; |
| my $max_minor = $minors_sorted[-1]; |
| my $minor_width = $max_minor > 10 ? 1+int(log($max_minor)/log(10)) : 2; |
| for my $m (@minors_sorted) { |
| my $t = $drbd{$m}; |
| my @used_by = exists $t->{xen_info} ? "xen-vbd: $t->{xen_info}" |
| : exists $t->{pv_info} ? pv_info $t->{pv_info} |
| : exists $t->{df_info} ? df_info $t->{df_info} |
| : exists $t->{virsh_info} ? virsh_info $t->{virsh_info} |
| : exists $t->{ll_dev_of} ? ll_dev_info $t->{ll_dev_of} |
| : (); |
| |
| $out[$line] = [ |
| sprintf("%*u:%s", $minor_width, $m, $t->{name} || "??not-found??"), |
| defined($t->{ll_dev}) ? "^^$t->{ll_dev}" : "", |
| $t->{conn}, |
| $t->{role}, |
| $t->{dstate}, |
| @used_by |
| ]; |
| for (my $c = 0; $c < @{$out[$line]}; $c++) { |
| # strip color codes for column width calculation |
| my $w = $out[$line][$c]; |
| $w =~ s/$ansi_color_re//og; |
| |
| my $l = length($w) + 1; |
| $out_plain[$line][$c] = $w; |
| $maxw[$c] = $l unless $maxw[$c] and $l < $maxw[$c]; |
| } |
| ++$line; |
| if (defined $t->{sync}) { |
| $out[$line++] = [ $t->{sync} ]; |
| } |
| } |
| for my $l (0 .. $#out) { |
| $_ = $out[$l]; |
| for (my $c2 = 0; $c2 < @$_; $c2++) { |
| # printf columns don't know about escape codes, need to pad manually. |
| print $_->[$c2], ' ' x ($maxw[$c2] - length($out_plain[$l][$c2])); |
| } |
| print "\n"; |
| } |