package INSTALL::process_info;

use INSTALL::os;
use INSTALL::common;

#------------------------------------------------------------------------------
# Retrieve the process information for the specified <pid>.  If no information
# exists for the specified process, then undef will be returned.  Otherwise,
# a hash containing information about that process will be returned.  If
# <force_rehash> is specified and evaluates to true, the results are guaranteed
# to be accurate to the time of the retrieval.  Otherwise, the results may be
# accurate only to the first time the retrieval was made.
#
# Note: The reason for the odd behavior of this call, regarding <force_rehash>
#       is that on some systems, polling for one specific process out of a
#       group of processes is relatively expensive.  As such, the information
#       about all processes is retrieved once (on such systems), and indexed
#       appropriately when requested.  Thus, if the user intends to traverse
#       all running processes, it would be wise to make the first invocation
#       with the <force_rehash> flag set, then to make subsequent queries with
#       the flag unset.
#
# Returned information:
#   binary = <a full path to the binary>
#   name   = <a shortened version of the binary, without pathing information>
#   pid    = <the supplied pid>
#   ppid   = <parent pid>
#   ruid   = <real user id of process>
#   euid   = <effective user id of process>
#   rgid   = <real group id of process>
#   egid   = <effective group id of process>
#   pArgv  = <a reference to a list of parameters, each being a string>
#   vmsize = <the size of virtual memory in use by the process (in bytes)>
#   residentsize = <the size of real memory is use by the process (in bytes)>
#   sharedsize = <the number of bytes of vm shared with other processes>
#------------------------------------------------------------------------------

INSTALL::os::detect;
my $pGlobals = \%INSTALL::global::variables;
my $pOS = \%INSTALL::os::Details;

{
  # Function static variables
  my (@ps_1, @ps_2);
  my (%prochash);

  sub initialize_statics
  {
    ($#_ <= 0) || die "Invalid number of arguments.";
    my ($force_rehash) = (@_) ;

    if ($force_rehash || ($#ps_1 < 0)) {
      # Initialize once, and only once.

      if ($pOS->{os} =~ /AIX/i) {
        @ps_1 =
          map { s/^\s+//g; s/\s+/ /g; $_ }
          grep { /^\s*[0-9]/ } split('\n',`ps -ekf -o pid,ppid,ruser,user,rgroup,group,args`);
        @ps_2 =
          map { s/^\s+//g; s/\s+/ /g; $_ }
          grep { /^\s*[0-9]/ } split('\n',`ps agvwwx`);
      }
      elsif ($pOS->{os} =~ /HP-UX/i) 
      {
        # HP-UX's 'ps' implementation is screwed up, so we need to use our own.
        my $ps = undef ;
        my @possible_ps_locations = 
          (
             "$pGlobals->{asphome}/INSTALL",
             "$pGlobals->{tools_bin_dir}"
          );
        foreach my $ps_path (@possible_ps_locations) 
        {
          next unless (-x "$ps_path/chili_ps" ) ;
          $ps = "$ps_path/chili_ps" ;
        }
        unless ($ps) {
          $ENV{UNIX95} = 1;
          $ps="/usr/bin/ps -A -o pid,ppid,uid,ruid,gid,rgid,sz,vsz,comm,args" ;
        }
        @ps_1 =
          map { s/^\s+//g; s/\s+/ /g; $_ }
          grep { /^\s*[0-9]/ } split('\n',`$ps`);
      }
      else {
        die "Unhandled OS making use of initialize_statistics";
      }
    }
  }


  #----------------------------------------------------------------------------
  # Retrieve a list of pids and their associated binary in a resultant hash
  # mapping pids to binary.
  #----------------------------------------------------------------------------
  sub retrieve_prochash
  {
    ($#_ <= 0) || die "Invalid number of arguments.";

    my ($force_rehash) = @_;

    if ((not $force_rehash) && (scalar(keys %prochash) != 0)) {
      return(%prochash);
    }

    for($pOS->{os}) {
      my $exeSet = 0;
      ###########################################################################
      /Linux/i &&
      ###########################################################################
        do {
          local *PROC;

          opendir(PROC,"/proc");
          @procs = grep { /^[0-9]+$/ } readdir(PROC);
          closedir(PROC);

          foreach(@procs) {
            my $pid = $_;
            my $binary;

            if (-f "/proc/$pid/exe") {
              $binary = readlink("/proc/$pid/exe");
            }
            elsif (open(CMDLINE,"/proc/$pid/cmdline")) {
              my @cmdline = split(/\x0/,join("",<CMDLINE>));
              close(CMDLINE);

              $binary = $cmdline[0];
            }

            $prochash{$pid} = $binary;
          }

          last;
        };

      ###########################################################################
      /AIX/i &&
      ###########################################################################
        do {
          initialize_statics(1);

          foreach(@ps_2) {
            # Strip leading whitespaces.
            my @proc_info = split(/\s+/,$_);

            my $pid = $proc_info[0];
            my $binary = $proc_info[12];

            $prochash{$pid} = $binary;
          }

          last;
        };

      ##########################################################################
      /HP-UX/i &&
      ##########################################################################
        do {
          initialize_statics(1);

          foreach(@ps_1) {
            # Strip leading whitespaces.
            my @proc_info = split(/\s+/,$_);

            my $pid = $proc_info[0];
            my $binary = $proc_info[8];

            $prochash{$pid} = $binary;
          }

          last;
        };

      #########################################################################
      /SunOS/i &&
      #########################################################################
        do {
          # typedef struct
          # {
          #   int     a_type;
          #   union {
          #     long    a_val;
          #     #ifdef __STDC__
          #     void    *a_ptr;
          #     #else
          #     char    *a_ptr;
          #     #endif
          #     void    (*a_fcn)();
          #   } a_un;
          # } auxv_t;
          # if (a_type == 2014), then use the provided offset as an offset into
          # the address space to find the full exec path.

          my $base = "/proc";
          local *PROC;

          opendir(PROC,$base);
          foreach my $subdir (readdir(PROC)) {
            my $path = "$base/$subdir";
            my $exec_offset;
            my $executable;

            if (open(AUXV,"<$path/auxv")) {
              my $auxv;
              while(read(AUXV,$auxv,8) == 8) {
                my ($a_type, $a_val) = unpack("LL",$auxv);

                if ($a_type == 2014) {
                  $exec_offset = $a_val;
                  last;
                }
              }
              close(AUXV);
            }

            if ($exec_offset && open(AS, "<$path/as")) {
              if (seek(AS,$exec_offset,0)) {
                while(read(AS,$executable,64,length($executable))) {
                  if ($executable =~ s@\x00.*$@@) {
                    last;
                  }
                }
              }
              close(AS);
            }

            if ($executable) {
              $prochash{$subdir} = $executable;
            }
          }

          closedir(PROC);
          last;
        };

      die "Unhandled platform: $pOS->{os}";
    }

    # print "Process pid list:\n  ",join("  ",map("$_\n",keys %prochash)),"\n";
    # print "Process binary list:\n  ",join("  ",map("$_\n",values %prochash)),"\n";
    return(%prochash);
  }

  sub process_info
  {
    (($#_ == 0) || ($#_ == 1)) || die "Invalid number of arguments.";

    my ($pid,$force_rehash) = @_;
    my ($binary,$name,$ppid,$ruid,$euid,$rgid,$egid,@argv,$vmsize,$residentsize,$sharedsize);
    my $result = 1;

    for($pOS->{os}) {
      my $exeSet = 0;

      #########################################################################
      /Linux/i &&
      #########################################################################
        do {
          my $basePath = "/proc/$pid";

          if (-d $basePath) {
            if (-f "$basePath/exe") {
              $exeSet = 1;
              $binary = readlink("/proc/$pid/exe");
            }

            if (-f "$basePath/status" && open(STATUS,"<$basePath/status")) {
              foreach(<STATUS>) {
                if (/^Name:\s*(.*)$/i) {
                  $name = $1;
                }
                elsif (/^PPid:\s*(.*)$/i) {
                  $ppid = $1;
                }
                elsif (/^Uid:\s*([0-9]+)\s+([0-9]+)\s+([0-9]+)\s+([0-9]+)\s*$/i) {
                  $ruid = $1;
                  $euid = $2;
                }
                elsif (/^Gid:\s*([0-9]+)\s+([0-9]+)\s+([0-9]+)\s+([0-9]+)\s*$/i) {
                  $rgid = $1;
                  $egid = $2;
                }
              }

              close(STATUS);
            }

            if (-f "$basePath/cmdline" && open(CMDLINE,"<$basePath/cmdline")) {
              @argv = split("\x0",<CMDLINE>);
              close(CMDLINE);

              if (not $exeSet) {
                $binary = $argv[0];
              }

              if (-f "$basePath/statm" && open(STATM,"<$basePath/statm")) {
                ($vmsize,$residentsize,$sharedsize) = split(/\s+/,<STATM>);

                my $CONST_PageSize = 4*1024;

                $vmsize *= $CONST_PageSize;
                $residentsize *= $CONST_PageSize;
                $sharedsize *= $CONST_PageSize;
              }
            }
          }
          else {
            goto ERROR_PROCESS_INFO;
          }

          last;
        };

      #########################################################################
      /AIX/i &&
      #########################################################################
        do {
          initialize_statics($force_rehash);
          my ($ps_1, $ps_2);

          foreach(@ps_1) {
            if (/^\s*$pid\s+/) {
              $ps_1 = $_;
              last;
            }
          }

          foreach(@ps_2) {
            if (/^\s*$pid\s+/) {
              $ps_2 = $_;
              last;
            }
          }

          if ($ps_1 && $ps_2) {
            (undef,$ppid,$ruser,$euser,$rgroup,$egroup,@argv) = split(/\s+/,$ps_1);
            (undef,undef,undef,undef,undef,undef,$residentsize,$sharedsize) = split(/\s+/,$ps_2);

            $ruid = getpwnam($ruser);
            $euid = getpwnam($euser);
            $rgid = getgrnam($rgroup);
            $egid = getgrnam($egroup);

            $binary = INSTALL::common::realpath($argv[0]);

            if (not defined $binary) {
              $binary = $argv[0];
            }

            $name = basename($binary);

            # How do you get the vm-size on AIX?
            $residentsize *= 1024;
            $vmsize = $residentsize;
          }
          elsif (wantarray) {
            return();
          }
          else {
            return(undef);
          }

          last;
        };

      #########################################################################
      /HP-UX/ &&
      #########################################################################
        do {
          # we will force this to rehash it every time, as our installer 
          # module solely depends on this for accuracy.
          initialize_statics(1);
          my $ps_1 ;

          foreach(@ps_1) {
            if (/^\s*$pid\s+/) {
              $ps_1 = $_;
              last;
            }
          }

          if ($ps_1) {
            (undef,$ppid,$ruser,$euser,$rgroup,$egroup,$residentsize,$vmsize,$binary,@argv) = split(/\s+/,$ps_1);

            $ruid = getpwnam($ruser);
            $euid = getpwnam($euser);
            $rgid = getgrnam($rgroup);
            $egid = getgrnam($egroup);

            $binary = INSTALL::common::realpath($argv[0]);

            if (not defined $binary) {
              $binary = $argv[0];
            }

            $name = basename($binary);

            # How do you get the shared-size on HP-UX?
            $residentsize *= (4*1024);
            $vmsize *= (1024);
            $sharedsize = 0;
          }
          elsif (wantarray) {
            return();
          }
          else {
            return(undef);
          }

          last;
        };

      #########################################################################
      /SunOS/i &&
      #########################################################################
        # typedef struct psinfo {
        #1         int     pr_flag;        /* process flags */
        #2         int     pr_nlwp;        /* number of lwps in process */
        #3         pid_t   pr_pid;         /* unique process id */
        #4         pid_t   pr_ppid;        /* process id of parent */
        #5         pid_t   pr_pgid;        /* pid of process group leader */
        #6         pid_t   pr_sid;         /* session id */
        #7         uid_t   pr_uid;         /* real user id */
        #8         uid_t   pr_euid;        /* effective user id */
        #1         gid_t   pr_gid;         /* real group id */
        #2         gid_t   pr_egid;        /* effective group id */
        #3         uintptr_t pr_addr;      /* address of process */
        #4         size_t  pr_size;        /* size of process image in Kbytes */
        #5         size_t  pr_rssize;      /* resident set size in Kbytes */
        #6         size_t  pr_pad;
        #7         dev_t   pr_ttydev;      /* controlling tty device (or PRNODEV) */
        #                         /* The following percent numbers are 16-bit binary */
        #                         /* fractions [0 .. 1] with the binary point to the */
        #                         /* right of the high-order bit (1.0 == 0x8000) */
        #8         u_short pr_pctcpu;      /* % of recent cpu time used by all lwps */
        #1         u_short pr_pctmem;      /* % of system memory used by process */
        #2         timestruc_t pr_start;   /* process start time, from the epoch */
        #3         timestruc_t pr_time;    /* usr+sys cpu time for this process */
        #4         timestruc_t pr_ctime;   /* usr+sys cpu time for reaped children */
        #5         char    pr_fname[PRFNSZ];       /* name of execed file */
        #6         char    pr_psargs[PRARGSZ];     /* initial characters of arg list */
        #7         int     pr_wstat;       /* if zombie, the wait() status */
        #8         int     pr_argc;        /* initial argument count */
        #1         uintptr_t pr_argv;      /* address of initial argument vector */
        #2         uintptr_t pr_envp;      /* address of initial environment vector */
        #3         int     pr_filler[8];   /* reserved for future use */
        #4         lwpsinfo_t pr_lwp;      /* information for representative lwp */
        # } psinfo_t;
        # sizeof(psinfo_t) == 336
        # sizeof(timestruc_t) == 8
        # PRFNSZ == 16
        # PRARGSZ == 80
        do {
          my $basePath = "/proc/$pid";
          my ($argc,$ppArgv);

          if (open(PSINFO,"</proc/$pid/psinfo")) {
            my $psinfo;

            if (read(PSINFO,$psinfo,336) == 336) {
              (
               undef,undef,undef,$ppid,undef,undef,$ruid,$euid,
               $rgid,$egid,undef,$vmsize,$residentsize,undef,undef,undef,
               undef,undef,undef,undef,undef,undef,undef,$argc,
               $ppArgv,undef,undef,undef
              ) = unpack("iiLLLLLL LLLLLLLS Sa8a8a8a16a80ii LLi8A*",$psinfo);

              $vmsize *= 1024;
              $residentsize *= 1024;
            }
            else {
              goto ERROR_PROCESS_INFO;
            }

            close(PSINFO);
          }

          if ($ppArgv && open(AS,"</proc/$pid/as")) {
            seek(AS,$ppArgv,0);

            my $pArgv;

            if (read(AS,$pArgv,4) == 4) {
              $pArgv = unpack("L",$pArgv);
              seek(AS,$pArgv,0);

              my (@new_args,$chunk);

              while(scalar(@new_args) <= $argc) {
                if (read(AS,$chunk,64,length($chunk)) == 64) {
                  @new_args = split(/\x0/,$chunk);
                }
                else {
                  goto ERROR_PROCESS_INFO;
                }
              }

              @argv = @new_args[0 .. ($argc - 1)];
            }
            else {
              goto ERROR_PROCESS_INFO;
            }

            close(AS);
          }

          retrieve_prochash;

          $binary = $prochash{$pid};
          $name = basename($argv[0]);

          last;
        };

      die "Unhandled platform: $pOS->{os}";
    }

    return
      (binary   => $binary,
       name     => $name,
       pid      => $pid,
       ppid     => $ppid,
       ruid     => $ruid,
       euid     => $euid,
       rgid     => $rgid,
       egid     => $egid,
       pArgv    => \@argv,
       vmsize   => ($vmsize ? $vmsize : 0),
       residentsize => ($residentsize ? $residentsize : 0),
       sharedsize   => ($sharedsize ? $sharedsize : 0)
      );

  ERROR_PROCESS_INFO:
    if (wantarray) {
      return();
    }
    else {
      return(undef);
    }
  }
}

#------------------------------------------------------------------------------
# Similar to retrieve_prochash (defined above), except instead return a list
# of pids.
#------------------------------------------------------------------------------
sub retrieve_pids
{
  ($#_ <= 0) || die "Invalid number of arguments.";
  my %hash = retrieve_prochash(@_);

  return(keys %hash);
}

#------------------------------------------------------------------------------
# Similar to retrieve_prochash (defined above), except instead return a list
# of binaries.
#------------------------------------------------------------------------------
sub retrieve_binaries
{
  ($#_ <= 0) || die "Invalid number of arguments.";
  my %hash = retrieve_prochash(@_);

  return(values %hash);
}

1;