use Proc::ProcTable rather than ps and pgrep

Rather than spawn off repeated shell calls to ps
and pgrep when running osrf_control --diagnostic
or --kill-with-fire, use Proc::ProcTable.  This
should result in better portability, and also runs
faster.

For example, prior to this patch, osrf_control -l --diagnostic
resulted in the following timing:

real    0m2.981s
user    0m1.152s
sys     0m2.284s

With this patch:

real    0m0.884s
user    0m0.580s
sys     0m0.328s

New Perl dependencies are:

  Proc::ProcessTable
  DateTime::Format::Duration

Signed-off-by: Galen Charlton <gmc@esilibrary.com>

diff --git a/bin/opensrf-perl.pl.in b/bin/opensrf-perl.pl.in
index 36d0f13..86b5011 100755 (executable)
--- a/bin/opensrf-perl.pl.in
+++ b/bin/opensrf-perl.pl.in
@@ -18,6 +18,9 @@ use strict; use warnings;
 use Getopt::Long;
 use Net::Domain qw/hostfqdn/;
 use POSIX qw/setsid :sys_wait_h/;
+use Proc::ProcessTable;
+use DateTime::Duration;
+use DateTime::Format::Duration;
 use OpenSRF::Utils::Logger q/$logger/;
 use OpenSRF::System;
 use OpenSRF::Transport::PeerHandle;
@@ -26,6 +29,10 @@ use OpenSRF::Transport::Listener;
 use OpenSRF::Utils;
 use OpenSRF::Utils::Config;
 
+# grab list of processes
+my $procs = Proc::ProcessTable->new( enable_ttys => 0 )->table;
+my %procs_by_pid = map { $_->pid => $_ } @{ $procs };
+
 my $opt_service = undef;
 my $opt_config = "@CONF_DIR@/opensrf_core.xml";
 my $opt_pid_dir = "@PID_DIR@/run/opensrf";
@@ -210,17 +217,53 @@ sub get_service_pids_from_file {
 sub get_service_pids_from_ps {
     my $service = shift;
 
-    my $ps = ($service eq 'router') ?
-        "ps x | grep 'OpenSRF Router'" :
-        "ps x | grep 'OpenSRF Listener \\[$service\\]'";
+    my $cmndline_re = ($service eq 'router') ?
+        qr/OpenSRF Router/ :
+        qr/OpenSRF Listener \[$service\]/;
 
-    $ps .= " | grep -v grep |  sed 's/^\\s*//' | cut -d' ' -f1";
-    my @pids = `$ps`;
-    s/^\s*|\n//g for @pids;
+    my @pids = 
+        map { $_->pid }
+        grep { ($_->cmndline =~ $cmndline_re) && ($_->uid == $<) }
+        @{ $procs };
+
+    return @pids;
+}
+
+sub get_drones_for_service {
+    my $service = shift;
+
+    my $cmndline_re = qr/OpenSRF Drone \[$service\]/;
+
+    my @pids = 
+        map { $_->pid }
+        grep { ($_->cmndline =~ $cmndline_re) && ($_->uid == $<) }
+        @{ $procs };
 
     return @pids;
+
+}
+
+sub get_process_uptime {
+    my $pid = shift;
+
+    return DateTime::Format::Duration->new(
+        pattern   => '%H:%M:%S',
+        normalize => 1,
+    )->format_duration(DateTime::Duration->new(
+        seconds => (time() - $procs_by_pid{$pid}->start)
+    ));
 }
 
+sub get_process_cputime {
+    my $pid = shift;
+
+    return DateTime::Format::Duration->new(
+        pattern   => '%H:%M:%S',
+        normalize => 1,
+    )->format_duration(DateTime::Duration->new(
+        nanoseconds => 1000 * $procs_by_pid{$pid}->time
+    ));
+}
 
 sub do_diagnostic {
     my $service = shift;
@@ -263,15 +306,13 @@ sub do_diagnostic {
             $seen{$pid} = 1;
 
             my $str = "$svc_str [$pid] ";
-            my $times = `ps -o etime=,cputime= $pid`;
-            $times =~ s/^\s+|\s+$//g;
-            my @times = split(/ /, $times);
-            $str .= sprintf("uptime=%-11s cputime=%-11s ", $times[0], $times[1]);
+            $str .= sprintf("uptime=%-11s cputime=%-11s ",
+                            get_process_uptime($pid), get_process_cputime($pid));
 
             if ($svc eq 'router') {
                 msg($str);
             } else {
-                my @drones = `pgrep -f "Drone \\[$svc\\]"`;
+                my @drones = get_drones_for_service($svc);
                 $str .= "#drones=".scalar(@drones);
                 if (my ($service_info) = grep {$_->{service} eq $svc} @conf_services) {
                     $str .= '/' . $service_info->{min_drones};
@@ -491,10 +532,7 @@ sub do_kill_with_fire {
 
     my @pids = get_running_pids();
     for (@pids) {
-        next unless $_ =~ /\d+/;
-        my $proc = `ps -p $_ -o cmd=`;
-        chomp $proc;
-        msg("killing with fire pid=$_ $proc");
+        msg("killing with fire pid=$_ " . $procs_by_pid{$_}->cmndline);
         kill('KILL', $_);
     }
 
@@ -511,17 +549,17 @@ sub get_running_pids {
     my @pids;
 
     # start with the listeners, then drones, then routers
-    my @greps = (
-        "ps x | grep 'OpenSRF Listener' ",
-        "ps x | grep 'OpenSRF Drone' ",
-        "ps x | grep 'OpenSRF Router' "
+    my @cmndline_res = (
+        qr/OpenSRF Listener/,
+        qr/OpenSRF Drone/,
+        qr/OpenSRF Router/,
     );
 
-    $_ .= "| grep -v grep |  sed 's/^\\s*//' | cut -d' ' -f1" for @greps;
-
-    for my $grep (@greps) {
-        my @spids = `$grep`;
-        s/^\s*|\n//g for @spids;
+    for my $cmndline_re (@cmndline_res) {
+        my @spids =
+            map { $_->pid }
+            grep { ($_->cmndline =~ $cmndline_re) && ($_->uid == $<) }
+            @{ $procs };
         push (@pids, @spids);
     }
 

diff --git a/src/extras/Makefile.install b/src/extras/Makefile.install
index dbb21ae..fa6f2e2 100644 (file)
--- a/src/extras/Makefile.install
+++ b/src/extras/Makefile.install
@@ -47,6 +47,7 @@ DEBS =  \
        libclass-dbi-abstractsearch-perl\
        libclass-dbi-sqlite-perl\
        libdatetime-format-builder-perl\
+       libdatetime-format-duration\
        libdatetime-format-mail-perl\
        libdatetime-perl\
        libdatetime-timezone-perl\
@@ -59,6 +60,7 @@ DEBS =  \
        libmodule-build-perl\
        libnet-dns-perl\
        libperl-dev\
+       libproc-processtable-perl\
        libreadline-dev\
        libtemplate-perl\
        libtest-pod-perl\
@@ -113,6 +115,7 @@ FEDORAS = \
        perl-Class-DBI-AbstractSearch \
        perl-Class-DBI-SQLite \
        perl-DateTime-Format-Builder \
+       perl-DateTime-Format-Duration \
        perl-DateTime-Format-ISO8601 \
        perl-DateTime-Format-Mail \
        perl-DateTime-Set \
@@ -125,6 +128,7 @@ FEDORAS = \
        perl-Module-Build \
        perl-Net-DNS \
        perl-Net-Server \
+       perl-Proc-ProcessTable \
        perl-SQL-Abstract-Limit \
        perl-Template-Toolkit \
        perl-Test-Deep \