#ifdef  PROCESSTABLE_THREAD
#define __REENTRANT
#endif
#ifdef __cplusplus
extern "C" {
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef __cplusplus
}
#endif
#ifdef  PROCESSTABLE_THREAD
#include <pthread.h>
#endif
/* dTHX was used in perl 5.005 */
#ifndef dTHX
#define dTHX dTHR
#endif
/********************/
/* General includes */
/********************/
#include <stdlib.h>
#include <stdio.h>
#include <fcntl.h>
#include <string.h>
#include <stdarg.h>
/* prototypes to make the compiler shut up */
void ppt_warn(const char*, ...);
void ppt_die(const char*, ...);
void store_ttydev(HV*, unsigned long);
void bless_into_proc(char* , char**, ...);
void OS_get_table();
char* OS_initialize();
char** Fields = NULL; 
int Numfields;
/* Cache a pointer the TTY device number hash for quick lookups */
HV* Ttydevs;
/* This holds a pointer to the list of process objects we will build */
AV* Proclist;
/* Our local varargs warn which can be called as extern by code
 * that doesn't know Perl internals (and thus doesn't have a
 * warn() defined).
 *
 * I think vwarn() and vcroak() have been changed to warn() and 
 * croak() in perl 5.8?? warn and croak exist in 5.6, but don't 
 * seem to accept format args.
 */
void ppt_warn(const char *pat, ...) {
    dTHX;
    va_list args;
    va_start(args, pat);
    vwarn(pat, &args);
    va_end(args);
}
/* same with croak */
void ppt_croak(const char *pat, ...) {
    dTHX;
    va_list args;
    va_start(args, pat);
    vcroak(pat, &args);
    va_end(args);
}
/* Look up the tty device, given the ttynum and store it */
void store_ttydev( HV* myhash, unsigned long ttynum ){
  SV** ttydev;
  char ttynumbuf[1024]; 
   
  sprintf(ttynumbuf, "%lu", ttynum);
  if( 
     Ttydevs != NULL &&
     (ttydev = hv_fetch(Ttydevs, ttynumbuf, strlen(ttynumbuf), 0)) != NULL 
     ){
    hv_store(myhash, "ttydev", strlen("ttydev"), newSVsv(*ttydev), 0); 
  }
  else{
    /* hv_store(myhash, "ttydev", strlen("ttydev"), newSV(0), 0); */ 
/*     Stuff an empty string into the hash if there is no tty; this */
/*     way the ttydev method won't return undef for nonexistent ttys. I'm */
/*     not sure if this is really the right behavior... */
    hv_store(myhash, "ttydev", strlen("ttydev"), newSVpv("",0), 0); 
  }
}
/**********************************************************************/
/* This gets called by OS-specific get_table                          */
/* format specifies what types are being passed in, in a string       */
/* containing these specifiers:                                       */
/*   A    ignore this array of strings                                */
/*   a    array of strings, delimated with NULL, next argument is len */
/*   S    ignore this string                                          */
/*   s    string                                                      */
/*   I    ignore this int                                             */
/*   i    int                                                         */
/*   L    ignore this long                                            */
/*   l    long                                                        */
/*   J    ignore this long-long                                       */
/*   j    long-long                                                   */
/*   U    ignore this unsigned                                        */
/*   u    unsigned                                                    */
/*   V    perl scalar value                                           */
/*   P    ignore this string                                          */
/*   p    unsigned long                                               */
/* fields is an array of pointers to field names                      */
/* following that is a var args list of field values                  */
/**********************************************************************/
void bless_into_proc(char* format, char** fields, ...){
  va_list args;
  char* key;
  char* s_val;
  SV *SV_val;
  int i_val;
  unsigned u_val;
  long l_val;
  unsigned long p_val;
  long long ll_val;
  HV* myhash;
  SV* ref;
  HV* mystash;
  SV* blessed;
  /* Blech */
  if(Fields == NULL){
    Fields = fields; 
    Numfields = strlen(format);
  }
  myhash = newHV(); /* create a perl hash */
  va_start(args, fields);
  while( *format ){
    key = *fields; 
    switch(*format)
      {
      case 'A': /* ignore; creates an undef value for this key in the hash */
        va_arg(args, char *);
        va_arg(args, int);
        hv_store(myhash, key, strlen(key), &PL_sv_undef, 0);
        break;
      case 'a':  /* string */
        s_val = va_arg(args, char *);
        i_val = va_arg(args, int);
        {
            int len;
            char *s;
            AV *av = newAV();
            for (s = s_val; s < (s_val + i_val); s += len + 1) {
                len = strlen(s);
                av_push (av, newSVpvn (s, len));
            }
            hv_store (myhash, key, strlen(key), newRV_noinc((SV *) av), 0);
        }
        break;
      case 'S': /* ignore; creates an undef value for this key in the hash */
        va_arg(args, char *);
        hv_store(myhash, key, strlen(key), newSV(0), 0);
        break;
      case 's':  /* string */
        s_val = va_arg(args, char *);
        hv_store(myhash, key, strlen(key), newSVpv(s_val, strlen(s_val)), 0);
        break;
      case 'I':  /* ignore; creates an undef value for this key in the hash */
        va_arg(args, int);
        hv_store(myhash, key, strlen(key), newSV(0), 0);
        break;
      case 'i':  /* int */
        i_val = va_arg(args, int);
        hv_store(myhash, key, strlen(key), newSViv(i_val), 0);
        /* Look up and store the tty if this is ttynum */
        if( !strcmp(key, "ttynum") ) store_ttydev( myhash, i_val );
        break;
      case 'U':  /* ignore; creates an undef value for this key in the hash */
        va_arg(args, unsigned );
        hv_store(myhash, key, strlen(key), newSV(0), 0);
        break;
      case 'u':  /* int */
        u_val = va_arg(args, unsigned);
        hv_store(myhash, key, strlen(key), newSVuv(u_val), 0);
        break;
      case 'L':  /* ignore; creates an undef value for this key in the hash */
        va_arg(args, long);
        hv_store(myhash, key, strlen(key), newSV(0), 0);
        break;
      case 'l':  /* long */
        l_val = va_arg(args, long);
        hv_store(myhash, key, strlen(key), newSVnv(l_val), 0);
        /* Look up and store the tty if this is ttynum */
        if( !strcmp(key, "ttynum") ) store_ttydev( myhash, l_val );
        break;
      case 'P':  /* ignore; creates an undef value for this key in the hash */
        va_arg(args, unsigned long);
        hv_store(myhash, key, strlen(key), newSV(0), 0);
        break;
      case 'p':  /* unsigned long */
        p_val = va_arg(args, unsigned long);
        hv_store(myhash, key, strlen(key), newSVnv(p_val), 0);
        break;
      case 'J':  /* ignore; creates an undef value for this key in the hash */
        va_arg(args, long long);
        hv_store(myhash, key, strlen(key), newSV(0), 0);
        break;
      case 'j':  /* long long */
        ll_val = va_arg(args, long long);
        hv_store(myhash, key, strlen(key), newSVnv(ll_val), 0);
        break;
      case 'V':  /* perl scalar value */
        SV_val = va_arg(args, SV *);
        hv_store(myhash, key, strlen(key), SV_val, 0);
        break;
      default:
        croak("Unknown data format type `%c' returned from OS_get_table", *format);
        va_end(args); 
      }
     
    format++;
    fields++;
  }
  /* objectify the hash */
  ref = newRV_noinc((SV*) myhash);                        /* create ref from hash pointer */
  mystash = gv_stashpv("Proc::ProcessTable::Process", 1); /* create symbol table for this obj */
  blessed = sv_bless(ref, mystash);                       /* bless it */
  /* push it onto the array */
  av_push(Proclist, blessed);
  va_end(args);
}
/**********************************************************************/
/* Generic funcs generated by h2xs                                    */
/**********************************************************************/
static int
not_here(s)
char *s;
{
    croak("%s not implemented on this architecture", s);
    return -1;
}
static double
constant(name, arg)
char *name;
int arg;
{
    errno = 0;
    switch (*name) {
    }
    errno = EINVAL;
    return 0;
not_there:
    errno = ENOENT;
    return 0;
}
#ifdef  PROCESSTABLE_THREAD
pthread_mutex_t _mutex_table;
pthread_mutex_t _mutex_new;
void
mutex_op(int lock, pthread_mutex_t *mutex)
{
        if (lock == 0) {        /*unlock*/
                pthread_mutex_unlock(mutex);
        } else {                /*lock*/
                pthread_mutex_lock(mutex);
        }
}
#endif
void
mutex_new(int lock)
{
#ifdef  PROCESSTABLE_THREAD
        mutex_op(lock, &_mutex_new);
#endif
}
void
mutex_table(int lock)
{
#ifdef  PROCESSTABLE_THREAD
        mutex_op(lock, &_mutex_table);
#endif
}
MODULE = Proc::ProcessTable             PACKAGE = Proc::ProcessTable            
PROTOTYPES: DISABLE
BOOT:
#ifdef  PROCESSTABLE_THREAD
        pthread_mutex_init(&_mutex_table, NULL);
        pthread_mutex_init(&_mutex_new, NULL);
#endif
void
mutex_new(lock)
        int lock
void
mutex_table(lock)
        int lock
double
constant(name,arg)
        char *          name
        int             arg
SV*
table(obj)
     SV*  obj
     CODE:
     /* Check that we have an actual object. 
       calling Proc::Processtable->table SIGSEVs
       calling on an actual object is valid my $proc_obj = Proc::ProcessTable->new; $proc_obj->table; 
     */
     if (!obj || !SvOK (obj) || !SvROK (obj) || !sv_isobject (obj)) {
         croak("Must call table from an initalized object created with new");
     }
     HV* hash;
     SV** fetched;
     mutex_table(1);
     /* Cache a pointer to the tty device hash */ 
     Ttydevs = perl_get_hv("Proc::ProcessTable::TTYDEVS", FALSE);
     /* dereference our object to a hash */
     hash = (HV*) SvRV(obj);
     /* If the Table array already exists on our object we clear it
        and store a pointer to it in Proclist */
     if( hv_exists(hash, "Table", 5) ){
       /* fetch the hash entry */
       fetched = hv_fetch(hash, "Table", 5, 0);
       /* what's stored in the hash is a ref to the array, so we need
          to dereference it */
       Proclist = (AV*) SvRV(*fetched);
       av_clear(Proclist);
     }
     else{
       /* Otherwise we create the array and store it on the object. */
       Proclist = newAV();
       hv_store(hash, "Table", 5, newRV_noinc((SV*)Proclist), 0);
     }
     /* Call get_table to build the process objects and push them onto
        the Proclist */
     OS_get_table();
     /* Return a ref to our process list */
     RETVAL = newRV_inc((SV*) Proclist);
     mutex_table(0);
      
     OUTPUT:
     RETVAL
void
fields(obj)
     SV*  obj
     PPCODE:
     /* see above.  This should be called on an object generated by new */
     if (!obj || !SvOK (obj) || !SvROK (obj) || !sv_isobject (obj)) {
         croak("Must call fields from an initalized object created with new");
     }
     int i;
     SV* my_sv;
     if( Fields == NULL ){
       PUSHMARK(SP);
       XPUSHs(obj);
       PUTBACK;
       perl_call_method("table", G_DISCARD);
     }
     EXTEND(SP,Numfields);
     for (i=0; i < Numfields; i++ ){
       my_sv = newSVpv(Fields[i],0);
       PUSHs(sv_2mortal(my_sv));
     }
void 
_initialize_os(obj)
     SV*  obj
     CODE:
     char* error;
     if( (error = OS_initialize()) != NULL ){
       croak("%s", error);
     }