=head1 NAME

Sys::Statistics::Linux::Processes - Collect linux process statistics.

=head1 SYNOPSIS

    use Sys::Statistics::Linux::Processes;

    my $lxs = Sys::Statistics::Linux::Processes->new;
    $lxs->init;
    sleep 1;
    my $stat = $lxs->get;

=head1 DESCRIPTION

Sys::Statistics::Linux::Processes gathers process informations from the virtual
F</proc> filesystem (procfs).

For more informations read the documentation of the front-end module
L<Sys::Statistics::Linux>.

=head1 PROCESS STATISTICS

Generated by F</proc/E<lt>pidE<gt>/stat>, F</proc/E<lt>pidE<gt>/status>,
F</proc/E<lt>pidE<gt>/cmdline> and F<getpwuid()>.

Note that if F</etc/passwd> isn't readable, the key owner is set to F<N/a>.

    ppid      -  The parent process ID of the process.
    nlwp      -  The number of light weight processes that runs by this process.
    owner     -  The owner name of the process.
    pgrp      -  The group ID of the process.
    state     -  The status of the process.
    session   -  The session ID of the process.
    ttynr     -  The tty the process use.
    minflt    -  The number of minor faults the process made.
    cminflt   -  The number of minor faults the child process made.
    mayflt    -  The number of mayor faults the process made.
    cmayflt   -  The number of mayor faults the child process made.
    stime     -  The number of jiffies the process have beed scheduled in kernel mode.
    utime     -  The number of jiffies the process have beed scheduled in user mode.
    ttime     -  The number of jiffies the process have beed scheduled (user + kernel).
    cstime    -  The number of jiffies the process waited for childrens have been scheduled in kernel mode.
    cutime    -  The number of jiffies the process waited for childrens have been scheduled in user mode.
    prior     -  The priority of the process (+15).
    nice      -  The nice level of the process.
    sttime    -  The time in jiffies the process started after system boot.
    actime    -  The time in D:H:M:S (days, hours, minutes, seconds) the process is active.
    vsize     -  The size of virtual memory of the process.
    nswap     -  The size of swap space of the process.
    cnswap    -  The size of swap space of the childrens of the process.
    cpu       -  The CPU number the process was last executed on.
    wchan     -  The "channel" in which the process is waiting.
    fd        -  This is a subhash containing each file which the process has open, named by its file descriptor.
                 0 is standard input, 1 standard output, 2 standard error, etc.
    cmd       -  Command of the process.
    cmdline   -  Command line of the process.

Generated by F</proc/E<lt>pidE<gt>/statm>. All statistics provides information
about memory in pages:

    size      -  The total program size of the process.
    resident  -  Number of resident set size, this includes the text, data and stack space.
    share     -  Total size of shared pages of the process.
    trs       -  Total text size of the process.
    drs       -  Total data/stack size of the process.
    lrs       -  Total library size of the process.
    dtp       -  Total size of dirty pages of the process (unused since kernel 2.6).

It's possible to convert pages to bytes or kilobytes. Example - if the pagesize of your
system is 4kb:

    $Sys::Statistics::Linux::Processes::PAGES_TO_BYTES =    0; # pages (default)
    $Sys::Statistics::Linux::Processes::PAGES_TO_BYTES =    4; # convert to kilobytes
    $Sys::Statistics::Linux::Processes::PAGES_TO_BYTES = 4096; # convert to bytes

=head1 METHODS

=head2 new()

Call C<new()> to create a new object.

    my $lxs = Sys::Statistics::Linux::Processes->new;

It's possible to handoff an array reference with a PID list.

    my $lxs = Sys::Statistics::Linux::Processes->new([ 1, 2, 3 ]);

=head2 init()

Call C<init()> to initialize the statistics.

    $lxs->init;

=head2 get()

Call C<get()> to get the statistics. C<get()> returns the statistics as a hash reference.

    my $stat = $lxs->get;

=head1 EXPORTS

No exports.

=head1 SEE ALSO

B<proc(5)>

B<perldoc -f getpwuid>

=head1 REPORTING BUGS

Please report all bugs to <jschulz.cpan(at)bloonix.de>.

=head1 AUTHOR

Jonny Schulz <jschulz.cpan(at)bloonix.de>.

=head1 COPYRIGHT

Copyright (c) 2006, 2007 by Jonny Schulz. All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

package Sys::Statistics::Linux::Processes;

use strict;
use warnings;
use Carp qw(croak);
use Time::HiRes;
use constant NUMBER => qr/^-{0,1}\d+(?:\.\d+){0,1}\z/;

our $VERSION = '0.22';
our $PAGES_TO_BYTES = 0;

sub new {
    my ($class, $pids) = @_;

   my %self = (
        files => {
            basedir   => '/proc',
            p_stat    => 'stat',
            p_statm   => 'statm',
            p_status  => 'status',
            p_cmdline => 'cmdline',
            p_wchan   => 'wchan',
        },
    );

    if ($pids) {
        if (ref($pids) ne 'ARRAY') {
            croak "$class: not a array reference";
        }

        foreach my $pid (@$pids) {
            if ($pid !~ /^\d+\z/) {
                croak "$class: pid '$pid' is not a number";
            }
        }

        $self{pids} = $pids;
    }

    return bless \%self, $class;
}

sub init {
    my $self = shift;
    $self->{init} = $self->_init;
}

sub get {
    my $self  = shift;
    my $class = ref $self;

    if (!exists $self->{init}) {
        croak "$class: there are no initial statistics defined";
    }

    $self->{stats} = $self->_load;
    $self->_deltas;
    return $self->{stats};
}

#
# private stuff
#

sub _init {
    my $self  = shift;
    my $class = ref $self;
    my $file  = $self->{files};
    my ($pids, %stats);

    $stats{time} = Time::HiRes::gettimeofday();

    if ($self->{pids}) {
        $pids = $self->{pids};
    } else {
        opendir my $pdir, $file->{basedir}
            or croak "$class: unable to open directory $file->{basedir} ($!)";
        $pids = [(grep /^\d+\z/, readdir $pdir)];
        closedir $pdir;
    }

    foreach my $pid (@$pids) {
        if (open my $fh, '<', "$file->{basedir}/$pid/$file->{p_stat}") {
            @{$stats{$pid}}{qw(
                minflt cminflt mayflt cmayflt utime
                stime cutime cstime sttime
            )} = (split /\s+/, <$fh>)[9..16,21];
            close($fh);
        } else {
            delete $stats{$pid};
            next;
        }
    }

    return \%stats;
}

sub _load {
    my $self  = shift;
    my $class = ref $self;
    my $file  = $self->{files};
    my ($pids, %stats, %userids);

    $stats{time} = Time::HiRes::gettimeofday();

    # we get all the PIDs from the /proc filesystem. if we are unable to open a file
    # of a process, then it can be that the process doesn't exist any more and
    # we will delete the hash key.

    if ($self->{pids}) {
        $pids = $self->{pids};
    } else {
        opendir my $pdir, $file->{basedir}
            or croak "$class: unable to open directory $file->{basedir} ($!)";
        $pids = [(grep /^\d+\z/, readdir $pdir)];
        closedir $pdir;
    }

    PID: foreach my $pid (@$pids) {

        # memory usage for each process
        if (open my $fh, '<', "$file->{basedir}/$pid/$file->{p_statm}") {
            #   size       total program size
            #   resident   resident set size
            #   share      shared pages
            #   text       text (code)
            #   lib        library
            #   data       data/stack
            #   dt         dirty pages (unused in Linux 2.6)
            if ($PAGES_TO_BYTES) {
                @{$stats{$pid}}{qw(size resident share trs lrs drs dtp)}
                    = map { $_ * $PAGES_TO_BYTES } split /\s+/, <$fh>;
            } else {
                @{$stats{$pid}}{qw(size resident share trs lrs drs dtp)} = split /\s+/, <$fh>;
            }

            close($fh);
        } else {
            delete $stats{$pid};
            next PID;
        }

        # different other informations for each process
        if (open my $fh, '<', "$file->{basedir}/$pid/$file->{p_stat}") {
            @{$stats{$pid}}{qw(
                cmd     state   ppid    pgrp    session ttynr   minflt
                cminflt mayflt  cmayflt utime   stime   cutime  cstime
                prior   nice    nlwp    sttime  vsize   nswap   cnswap
                cpu
            )} = (split /\s+/, <$fh>)[1..6,9..19,21..22,35..36,38];
            close($fh);
        } else {
            delete $stats{$pid};
            next PID;
        }

        # calculate the active time of each process
        my ($d, $h, $m, $s) = $self->_calsec(sprintf('%li', $stats{time} - $stats{$pid}{sttime} / 100));
        $stats{$pid}{actime} = "$d:".sprintf('%02d:%02d:%02d', $h, $m, $s);

        # determine the owner of the process
        if (open my $fh, '<', "$file->{basedir}/$pid/$file->{p_status}") {
            while (my $line = <$fh>) {
                next unless $line =~ /^Uid:(?:\s+|\t+)(\d+)/;
                $stats{$pid}{owner} = getpwuid($1) || 'N/a';
                last;
            }
            close($fh);
        } else {
            delete $stats{$pid};
            next PID;
        }

        # command line for each process
        if (open my $fh, '<', "$file->{basedir}/$pid/$file->{p_cmdline}") {
            $stats{$pid}{cmdline} = <$fh>;
            if ($stats{$pid}{cmdline}) {
                $stats{$pid}{cmdline} =~ s/\0/ /g;
                $stats{$pid}{cmdline} =~ s/^\s+//;
                $stats{$pid}{cmdline} =~ s/\s+$//;
                chomp $stats{$pid}{cmdline};
            }
            $stats{$pid}{cmdline} = 'N/a' unless $stats{$pid}{cmdline};
            close($fh);
        } else {
            delete $stats{$pid};
            next PID;
        }

        if (open my $fh, '<', "$file->{basedir}/$pid/$file->{p_wchan}") {
            $stats{$pid}{wchan} = <$fh>;
            chomp($stats{$pid}{wchan});
        } else {
            delete $stats{$pid};
            next PID;
        }

        if (opendir my $dh, "$file->{basedir}/$pid/fd") {
            $stats{$pid}{fd} = { }; # maybe $dh is empty
            foreach my $link (grep !/^\.+\z/, readdir($dh)) {
                if (my $target = readlink("$file->{basedir}/$pid/fd/$link")) {
                    $stats{$pid}{fd}{$link} = $target;
                } else {
                    delete $stats{$pid};
                    next PID;
                }
            }
        } else {
            delete $stats{$pid};
            next PID;
        }
    }

    return \%stats;
}

sub _deltas {
    my $self  = shift;
    my $class = ref $self;
    my $istat = $self->{init};
    my $lstat = $self->{stats};

    if (!defined $istat->{time} || !defined $lstat->{time}) {
        croak "$class: not defined key found 'time'";
    }

    if ($istat->{time} !~ NUMBER || $lstat->{time} !~ NUMBER) {
        croak "$class: invalid value for key 'time'";
    }

    my $time = $lstat->{time} - $istat->{time};
    $istat->{time} = $lstat->{time};
    delete $lstat->{time};

    for my $pid (keys %{$lstat}) {
        my $ipid = $istat->{$pid};
        my $lpid = $lstat->{$pid};

        # yeah, what happends if the start time is different... it seems that a new
        # process with the same process-id were created... for this reason I have to
        # check if the start time is equal!
        if ($ipid && $ipid->{sttime} == $lpid->{sttime}) {
            for my $k (qw(minflt cminflt mayflt cmayflt utime stime cutime cstime)) {
                if (!defined $ipid->{$k}) {
                    croak "$class: not defined key found '$k'";
                }
                if ($ipid->{$k} !~ NUMBER || $lpid->{$k} !~ NUMBER) {
                    croak "$class: invalid value for key '$k'";
                }

                # $tmp is used for the next init stat
                my $tmp      = $lpid->{$k};
                $lpid->{$k} -= $ipid->{$k};
                if ($lpid->{$k} > 0 && $time > 0) {
                    $lpid->{$k} = sprintf('%.2f', $lpid->{$k} / $time);
                } else {
                    $lpid->{$k} = sprintf('%.2f', $lpid->{$k});
                }
                $ipid->{$k} = $tmp;
            }
            # total workload
            $lpid->{ttime} = sprintf('%.2f', $lpid->{stime} + $lpid->{utime});
        } else {
            # if the start time is not equal then it seems to be a new process
            for my $k (qw(minflt cminflt mayflt cmayflt utime stime cutime cstime sttime)) {
                $istat->{$pid}->{$k} = $lpid->{$k};
                delete $lstat->{$pid};
            }
        }
    }
}

sub _calsec {
    my $self = shift;
    my ($s, $m, $h, $d) = (shift, 0, 0, 0);
    $s >= 86400 and $d = sprintf('%i', $s / 86400) and $s = $s % 86400;
    $s >= 3600  and $h = sprintf('%i', $s / 3600)  and $s = $s % 3600;
    $s >= 60    and $m = sprintf('%i', $s / 60)    and $s = $s % 60;
    return ($d, $h, $m, $s);
}

1;
