copy on write の チェックスクリプト(starlet)

cow_check.pl

#!/usr/bin/perl
use strict;
use warnings;
use Linux::Smaps;

my $proc_name = 'plackup';#shift or die "usage: $0 PROC_NAME";

my $proc_list = `ps ax|grep $proc_name` || '';

my @pid_list;
for my $proc (split /\n/, $proc_list) {
    if ($proc =~ m!$proc_name! && $proc !~ m!grep plackup!) {
    #if ($proc =~ m!$proc_name.*[^\-](master|worker)!) {
        my $type = $1;
        my ($pid) = ($proc =~ m!^[^\d]*(\d+)[^\d]!);
        push @pid_list, +{ type => $type, pid => $pid };
    }
}

die "not exists $proc_name" unless @pid_list;

printf "PID\tTYPE\tRSS\tSHARED\n";

for my $p (@pid_list) {
    my $map = Linux::Smaps->new($p->{pid});
    unless ($map) {
        warn $!;
        next;
    }
    printf
        "%d\t%d\t%d (%d%%)\n",
        $p->{pid},
#        $p->{type},
        $map->rss,
        $map->shared_dirty + $map->shared_clean,
        int((($map->shared_dirty + $map->shared_clean) / $map->rss) * 100)
}