/*
 * This file was generated automatically by ExtUtils::ParseXS version 3.35 from the
 * contents of ProcessTable.xs. Do not edit this file, edit ProcessTable.xs instead.
 *
 *    ANY CHANGES MADE HERE WILL BE LOST!
 *
 */

#line 1 "ProcessTable.xs"
#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:                                       */
/*   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 '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
}

#line 301 "ProcessTable.c"
#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(var) if (0) var = var
#endif

#ifndef dVAR
#  define dVAR		dNOOP
#endif


/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
#  define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
#  define PERL_DECIMAL_VERSION \
	  PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
#  define PERL_VERSION_GE(r,v,s) \
	  (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
#  define PERL_VERSION_LE(r,v,s) \
	  (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif

/* XS_INTERNAL is the explicit static-linkage variant of the default
 * XS macro.
 *
 * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
 * "STATIC", ie. it exports XSUB symbols. You probably don't want that
 * for anything but the BOOT XSUB.
 *
 * See XSUB.h in core!
 */


/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
#  undef XS_EXTERNAL
#  undef XS_INTERNAL
#  if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
#    define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
#    define XS_INTERNAL(name) STATIC XSPROTO(name)
#  endif
#  if defined(__SYMBIAN32__)
#    define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
#    define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
#  endif
#  ifndef XS_EXTERNAL
#    if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
#      define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
#      define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
#    else
#      ifdef __cplusplus
#        define XS_EXTERNAL(name) extern "C" XSPROTO(name)
#        define XS_INTERNAL(name) static XSPROTO(name)
#      else
#        define XS_EXTERNAL(name) XSPROTO(name)
#        define XS_INTERNAL(name) STATIC XSPROTO(name)
#      endif
#    endif
#  endif
#endif

/* perl >= 5.10.0 && perl <= 5.15.1 */


/* The XS_EXTERNAL macro is used for functions that must not be static
 * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
 * macro defined, the best we can do is assume XS is the same.
 * Dito for XS_INTERNAL.
 */
#ifndef XS_EXTERNAL
#  define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
#  define XS_INTERNAL(name) XS(name)
#endif

/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
 * internal macro that we're free to redefine for varying linkage due
 * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
 * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
 */

#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
#  define XS_EUPXS(name) XS_EXTERNAL(name)
#else
   /* default to internal */
#  define XS_EUPXS(name) XS_INTERNAL(name)
#endif

#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)

/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params);

STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params)
{
    const GV *const gv = CvGV(cv);

    PERL_ARGS_ASSERT_CROAK_XS_USAGE;

    if (gv) {
        const char *const gvname = GvNAME(gv);
        const HV *const stash = GvSTASH(gv);
        const char *const hvname = stash ? HvNAME(stash) : NULL;

        if (hvname)
	    Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
        else
	    Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
    } else {
        /* Pants. I don't think that it should be possible to get here. */
	Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
    }
}
#undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE

#define croak_xs_usage        S_croak_xs_usage

#endif

/* NOTE: the prototype of newXSproto() is different in versions of perls,
 * so we define a portable version of newXSproto()
 */
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */

#if PERL_VERSION_LE(5, 21, 5)
#  define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
#else
#  define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#endif

#line 445 "ProcessTable.c"

XS_EUPXS(XS_Proc__ProcessTable_mutex_new); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Proc__ProcessTable_mutex_new)
{
    dVAR; dXSARGS;
    if (items != 1)
       croak_xs_usage(cv,  "lock");
    {
	int	lock = (int)SvIV(ST(0))
;

	mutex_new(lock);
    }
    XSRETURN_EMPTY;
}


XS_EUPXS(XS_Proc__ProcessTable_mutex_table); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Proc__ProcessTable_mutex_table)
{
    dVAR; dXSARGS;
    if (items != 1)
       croak_xs_usage(cv,  "lock");
    {
	int	lock = (int)SvIV(ST(0))
;

	mutex_table(lock);
    }
    XSRETURN_EMPTY;
}


XS_EUPXS(XS_Proc__ProcessTable_constant); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Proc__ProcessTable_constant)
{
    dVAR; dXSARGS;
    if (items != 2)
       croak_xs_usage(cv,  "name, arg");
    {
	char *	name = (char *)SvPV_nolen(ST(0))
;
	int	arg = (int)SvIV(ST(1))
;
	double	RETVAL;
	dXSTARG;

	RETVAL = constant(name, arg);
	XSprePUSH; PUSHn((double)RETVAL);
    }
    XSRETURN(1);
}


XS_EUPXS(XS_Proc__ProcessTable_table); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Proc__ProcessTable_table)
{
    dVAR; dXSARGS;
    if (items != 1)
       croak_xs_usage(cv,  "obj");
    {
	SV*	obj = ST(0)
;
	SV *	RETVAL;
#line 318 "ProcessTable.xs"
     /* Check that we have an actual object. 
       calling Proc::Processtable->table SIGSEVs
       calling on an actual object is valid my $proc_obj = new Proc::ProcessTable; $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);

#line 556 "ProcessTable.c"
	RETVAL = sv_2mortal(RETVAL);
	ST(0) = RETVAL;
    }
    XSRETURN(1);
}


XS_EUPXS(XS_Proc__ProcessTable_fields); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Proc__ProcessTable_fields)
{
    dVAR; dXSARGS;
    if (items != 1)
       croak_xs_usage(cv,  "obj");
    PERL_UNUSED_VAR(ax); /* -Wall */
    SP -= items;
    {
	SV*	obj = ST(0)
;
#line 371 "ProcessTable.xs"
     /* 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));
     }
#line 596 "ProcessTable.c"
	PUTBACK;
	return;
    }
}


XS_EUPXS(XS_Proc__ProcessTable__initialize_os); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Proc__ProcessTable__initialize_os)
{
    dVAR; dXSARGS;
    if (items != 1)
       croak_xs_usage(cv,  "obj");
    {
	SV*	obj = ST(0)
;
#line 396 "ProcessTable.xs"
     char* error;

     if( (error = OS_initialize()) != NULL ){
       croak("%s", error);
     }
#line 618 "ProcessTable.c"
    }
    XSRETURN_EMPTY;
}

#ifdef __cplusplus
extern "C"
#endif
XS_EXTERNAL(boot_Proc__ProcessTable); /* prototype to pass -Wmissing-prototypes */
XS_EXTERNAL(boot_Proc__ProcessTable)
{
#if PERL_VERSION_LE(5, 21, 5)
    dVAR; dXSARGS;
#else
    dVAR; dXSBOOTARGSXSAPIVERCHK;
#endif
#if (PERL_REVISION == 5 && PERL_VERSION < 9)
    char* file = __FILE__;
#else
    const char* file = __FILE__;
#endif

    PERL_UNUSED_VAR(file);

    PERL_UNUSED_VAR(cv); /* -W */
    PERL_UNUSED_VAR(items); /* -W */
#if PERL_VERSION_LE(5, 21, 5)
    XS_VERSION_BOOTCHECK;
#  ifdef XS_APIVERSION_BOOTCHECK
    XS_APIVERSION_BOOTCHECK;
#  endif
#endif

        newXS_deffile("Proc::ProcessTable::mutex_new", XS_Proc__ProcessTable_mutex_new);
        newXS_deffile("Proc::ProcessTable::mutex_table", XS_Proc__ProcessTable_mutex_table);
        newXS_deffile("Proc::ProcessTable::constant", XS_Proc__ProcessTable_constant);
        newXS_deffile("Proc::ProcessTable::table", XS_Proc__ProcessTable_table);
        newXS_deffile("Proc::ProcessTable::fields", XS_Proc__ProcessTable_fields);
        newXS_deffile("Proc::ProcessTable::_initialize_os", XS_Proc__ProcessTable__initialize_os);

    /* Initialisation Section */

#line 295 "ProcessTable.xs"
#ifdef	PROCESSTABLE_THREAD
	pthread_mutex_init(&_mutex_table, NULL);
	pthread_mutex_init(&_mutex_new, NULL);
#endif

#line 666 "ProcessTable.c"

    /* End of Initialisation Section */

#if PERL_VERSION_LE(5, 21, 5)
#  if PERL_VERSION_GE(5, 9, 0)
    if (PL_unitcheckav)
        call_list(PL_scopestack_ix, PL_unitcheckav);
#  endif
    XSRETURN_YES;
#else
    Perl_xs_boot_epilog(aTHX_ ax);
#endif
}

