[perl5.git] / mpeix / mpeix.c


/*
 * gcc long pointer support code for HPPA.
 * Copyright 1998, DIS International, Ltd.
 * This code is free software; you may redistribute it and/or modify
 * it under the same terms as Perl itself.  (Relicensed for Perl in
 * in April 2002 by Mark Klein.)
 */
typedef struct {
  int           spaceid;
  unsigned int  offset;
  } LONGPOINTER, longpointer;

/*
 * gcc long pointer support code for HPPA.
 * Copyright 1998, DIS International, Ltd.
 * This code is free software; you may redistribute it and/or modify
 * it under the same terms as Perl itself.  (Relicensed for Perl in
 * in April 2002 by Mark Klein.)
 */

int __perl_mpe_getspaceid(void *source)
  {
  int val;
  /*
   * Given the short pointer, determine it's space ID.
   */

  /*
   * The colons separate output from input parameters. In this case,
   * the output of the instruction (output indicated by the "=" in the
   * constraint) is to a memory location (indicated by the "m"). The
   * input constraint indicates that the source to the instruction
   * is a register reference (indicated by the "r").
   * The general format is:
   *   asm("<instruction template>" : <output> : <input> : <clobbers>);
   *     where <output> and <input> are:
   *       "<constraint>" (<token>)
   *     <instruction template> is the PA-RISC instruction in template fmt.
   *     <clobbers> indicates those registers clobbered by the instruction
   *     and provides hints to the optimizer.
   *
   * Refer to the gcc documentation or http://www.dis.com/gnu/gcc_toc.html
   */
  __asm__ __volatile__ (
      "   comiclr,= 0,%1,%%r28\n"
      "\t  ldsid (%%r0,%1),%%r28\n"
      "\t stw %%r28, %0"
                        : "=m" (val)    // Output to val
                        : "r" (source)  // Source must be gen reg
                        : "%r28");      // Clobbers %r28
  return (val);
  };

LONGPOINTER __perl_mpe_longaddr(void *source)
  {
  LONGPOINTER lptr;
  /*
   * Return the long pointer for the address in sr5 space.
   */

  __asm__ __volatile__ (
      "  comiclr,= 0,%2,%%r28\n"
      "\t    ldsid (%%r0,%2),%%r28\n"
      "\t  stw %%r28, %0\n"
      "\t  stw %2, %1"
                        : "=m" (lptr.spaceid),
                          "=m" (lptr.offset)    // Store to lptr
                        : "r" (source)          // Source must be gen reg
                        : "%r28");      // Clobbers %r28
  return (lptr);
  };

LONGPOINTER __perl_mpe_addtopointer(LONGPOINTER source,    // %r26 == source offset
                                                // %r25 == source space
                        int             len)    // %r24 == length in bytes
  {
  /*
   * Increment a longpointer.
   */

  __asm__ __volatile__ (
      "  copy %0,%%r28\n"                       // copy space to r28
      "\t  add %1,%2,%%r29"                     // Increment the pointer
                        :                       // No output
                        : "r" (source.spaceid), // Source address
                          "r" (source.offset),
                          "r" (len)             // Length
                        : "%r28",               // Clobbers
                          "%r29");
  };

void __perl_mpe_longmove(int len,                  // %r26 == byte length
              LONGPOINTER source,       // %r23 == source space, %r24 == off
              LONGPOINTER target)       // sp-#56 == target space, sp-#52== off
  {
  /*
   * Move data between two buffers in long pointer space.
   */

  __asm__ __volatile__ (
      "  .import $$lr_unk_unk_long,MILLICODE\n"
      "\t  mtsp %0,%%sr1\n"                     // copy source space to sr1
      "\t  copy %1,%%r26\n"                     // load source offset to r26
      "\t  copy %4,%%r24\n"                     // load length to r24
      "\t  copy %3,%%r25\n"                     // load target offset to r25
      "\t  bl $$lr_unk_unk_long,%%r31\n"        // start branch to millicode
      "\t  mtsp %2,%%sr2"                       // copy target space to sr2
                        :                       // No output
                        : "r" (source.spaceid), // Source address
                          "r" (source.offset),
                          "r" (target.spaceid), // Target address
                          "r" (target.offset),
                          "r" (len)             // Byte length
                        : "%r1",                // Clobbers
                          "%r24",
                          "%r25",
                          "%r26",
                          "%r31");
  };

int __perl_mpe_longpeek(LONGPOINTER source)
  {
  /*
   * Fetch the int in long pointer space.
   */
  unsigned int val;

  __asm__ __volatile__ (
      "  mtsp %1, %%sr1\n"
      "\t  copy %2, %%r28\n"
      "\t  ldw 0(%%sr1, %%r28), %%r28\n"
      "\t  stw %%r28, %0"
                        : "=m" (val)            // Output val
                        : "r" (source.spaceid), // Source space ID
                          "r" (source.offset)   // Source offset
                        : "%r28");              // Clobbers %r28

  return (val);
  };

void __perl_mpe_longpoke(LONGPOINTER target,       // %r25 == spaceid, %r26 == offset
          unsigned int val)             // %r24 == value
  {
  /*
   * Store the val into long pointer space.
   */
  __asm__ __volatile__ (
      "  mtsp %0,%%sr1\n"
      "\t  copy %1, %%r28\n"
      "\t  stw %2, 0(%%sr1, %%r28)"
                        :                       // No output
                        : "r" (target.spaceid), // Target space ID
                          "r" (target.offset),  // Target offset
                          "r" (val)             // Value to store
                        : "%r28"                // Clobbers %r28
                        );                      // Copy space to %sr1
  };

void __perl_mpe_move_fast(int len,                 // %r26 == byte length
               void *source,            // %r25 == source addr
               void *target)            // %r24 == target addr
  {
  /*
   * Move using short pointers.
   */
  __asm__ __volatile__ (
      "  .import $$lr_unk_unk,MILLICODE\n"
      "\t  copy %1, %%r26\n"                    // Move source addr into pos
      "\t  copy %2, %%r25\n"                    // Move target addr into pos
      "\t  bl $$lr_unk_unk,%%r31\n"             // Start branch to millicode
      "\t  copy %0, %%r24"                      // Move length into position
                        :                       // No output
                        : "r" (len),            // Byte length
                          "r" (source),         // Source address
                          "r" (target)          // Target address
                        : "%r24",               // Clobbers
                          "%r25",
                          "%r26",
                          "%r31");
  };

/*
 * ftruncate - set file size, BSD Style
 *
 * shortens or enlarges the file as neeeded
 * uses some undocumented locking call. It is known to work on SCO unix,
 * other vendors should try.
 * The #error directive prevents unsupported OSes
 *
 * ftruncate/truncate code by Mark Bixby.
 * This code is free software; you may redistribute it and/or modify
 * it under the same terms as Perl itself.
 *
 */

#include <unistd.h>
#include <errno.h>
#include <fcntl.h>
#include <stdio.h>
#include <mpe.h>

extern void FCONTROL(short, short, longpointer);
extern void PRINTFILEINFO(int);

int ftruncate(int fd, long wantsize);

int ftruncate(int fd, long wantsize) {

int ccode_return,dummy=0;

if (lseek(fd, wantsize, SEEK_SET) < 0) {
        return (-1);
}

FCONTROL(_mpe_fileno(fd),6,__perl_mpe_longaddr(&dummy)); /* Write new EOF */
if ((ccode_return=ccode()) != CCE) {
        fprintf(stderr,"MPE ftruncate failed, ccode=%d, wantsize=%ld\n",ccode_return,wantsize);
        PRINTFILEINFO(_mpe_fileno(fd));
	errno = ESYSERR;
	return (-1);
}

return (0);
}

/*
   wrapper for truncate():

   truncate() is UNIX, not POSIX.

   This function requires ftruncate().


   NAME
      truncate -

   SYNOPSIS
      #include <unistd.h>

      int truncate(const char *pathname, off_t length);

                                             Returns: 0 if OK, -1 on error

            from: Stevens' Advanced Programming in the UNIX Environment, p. 92


   ERRORS
      EACCES
      EBADF
      EDQUOT (not POSIX)    <- not implemented here
      EFAULT
      EINVAL
      EISDIR
      ELOOP (not POSIX)     <- not implemented here
      ENAMETOOLONG
      ENOTDIR
      EROFS
      ETXTBSY (not POSIX)   <- not implemented here

                                          from: HP-UX man page


   Compile directives:
      PRINT_ERROR - make this function print an error message to stderr
*/

#ifndef _POSIX_SOURCE
# define _POSIX_SOURCE
#endif

#include <sys/types.h>	/* off_t, required by open() */
#include <sys/stat.h>	/* required by open() */
#include <fcntl.h>	/* open() */
#include <unistd.h>	/* close() */
#include <stdio.h>	/* perror(), sprintf() */


int
truncate(const char *pathname, off_t length)
{
	int fd;
#ifdef PRINT_ERROR
	char error_msg[80+1];
#endif

	if (length == 0)
	{
		if ( (fd = open(pathname, O_WRONLY | O_TRUNC)) < 0)
		{
			/* errno already set */
#ifdef PRINT_ERROR
			sprintf(error_msg,
			        "truncate(): open(%s, O_WRONLY | OTRUNC)\0",
			        pathname);
			perror(error_msg);
#endif
			return -1;
		}
	}
	else
	{
		if ( (fd = open(pathname, O_WRONLY)) < 0)
		{
			/* errno already set */
#ifdef PRINT_ERROR
			sprintf(error_msg,
			        "truncate(): open(%s, O_WRONLY)\0",
			        pathname);
			perror(error_msg);
#endif
			return -1;
		}

		if (ftruncate(fd, length) < 0)
		{
			/* errno already set */
#ifdef PRINT_ERROR
			perror("truncate(): ftruncate()");
#endif
			return -1;
		}
	}

	if (close(fd) < 0)
	{
		/* errno already set */
#ifdef PRINT_ERROR
		perror("truncate(): close()");
#endif
		return -1;
	}

	return 0;
} /* truncate() */

/* 
   wrapper for gettimeofday():
      gettimeofday() is UNIX, not POSIX.
      gettimeofday() is a BSD function.

   NAME
      gettimeofday -

   SYNOPSIS
      #include <sys/time.h>

      int gettimeofday(struct timeval *tp, struct timezone *tzp);

   DESCRIPTION
      This function returns seconds and microseconds since midnight
      January 1, 1970. The microseconds is actually only accurate to
      the millisecond.

      Note: To pick up the definitions of structs timeval and timezone
            from the <time.h> include file, the directive
            _SOCKET_SOURCE must be used.

   RETURN VALUE
      A 0 return value indicates that the call succeeded.  A -1 return
      value indicates an error occurred; errno is set to indicate the
      error.

   ERRORS
      EFAULT     not implemented

   Changes:
      2-91    DR.  Created.
*/


/* need _SOCKET_SOURCE to pick up structs timeval and timezone in time.h */
#ifndef _SOCKET_SOURCE
# define _SOCKET_SOURCE
#endif

#include <time.h>	/* structs timeval & timezone,
				difftime(), localtime(), mktime(), time() */
#include <sys/time.h>	/* gettimeofday() */

extern int TIMER();

/*
 * gettimeofday code by Mark Bixby.
 * This code is free software; you may redistribute it and/or modify
 * it under the same terms as Perl itself.
 */

#ifdef __STDC__
int gettimeofday( struct timeval *tp, struct timezone *tpz )
#else
int gettimeofday(  tp, tpz )
struct timeval  *tp;
struct timezone *tpz;
#endif
{
   static unsigned long    basetime        = 0;
   static int              dsttime         = 0;
   static int              minuteswest     = 0;
   static int              oldtime         = 0;
   register int            newtime;


   /*-------------------------------------------------------------------*/
   /* Setup a base from which all future time will be computed.         */
   /*-------------------------------------------------------------------*/
   if ( basetime == 0 )
   {
      time_t    gmt_time;
      time_t    loc_time;
      struct tm *loc_time_tm;

      gmt_time    = time( NULL );
      loc_time_tm = localtime( &gmt_time ) ;
      loc_time    = mktime( loc_time_tm );

      oldtime     = TIMER();
      basetime    = (unsigned long) ( loc_time - (oldtime/1000) );

      /*----------------------------------------------------------------*/
      /* The calling process must be restarted if timezone or dst       */
      /* changes.                                                       */
      /*----------------------------------------------------------------*/
      minuteswest = (int) (difftime( loc_time, gmt_time ) / 60);
      dsttime     = loc_time_tm->tm_isdst;
   }

   /*-------------------------------------------------------------------*/
   /* Get the new time value. The timer value rolls over every 24 days, */
   /* so if the delta is negative, the basetime value is adjusted.      */
   /*-------------------------------------------------------------------*/
   newtime = TIMER();
   if ( newtime < oldtime )  basetime += 2073600;
   oldtime = newtime;

   /*-------------------------------------------------------------------*/
   /* Return the timestamp info.                                        */
   /*-------------------------------------------------------------------*/
   tp->tv_sec          = basetime + newtime/1000;
   tp->tv_usec         = (newtime%1000) * 1000;   /* only accurate to milli */
   if (tpz)
   {
      tpz->tz_minuteswest = minuteswest;
      tpz->tz_dsttime     = dsttime;
   }

   return 0;

} /* gettimeofday() */

/*
**  MPE_FCNTL -- shadow function for fcntl()
**
**	MPE requires sfcntl() for sockets, and fcntl() for everything 
**	else.  This shadow routine determines the descriptor type and
**	makes the appropriate call.
**
**	Parameters:
**		same as fcntl().
**
**	Returns:
**		same as fcntl().
*/

#include <stdarg.h>
#include <sys/socket.h>

int
mpe_fcntl(int fildes, int cmd, ...)
{
	int len, result;
	struct sockaddr sa;
	
	void *arg;
	va_list ap;
	
	va_start(ap, cmd);
	arg = va_arg(ap, void *);
	va_end(ap);
	
	len = sizeof sa;
	if (getsockname(fildes, &sa, &len) == -1)
	{
	        if (errno == EAFNOSUPPORT)
			/* AF_UNIX socket */
	                return sfcntl(fildes, cmd, arg);

	        if (errno == ENOTSOCK) 
			/* file or pipe */
	                return fcntl(fildes, cmd, arg);

		/* unknown getsockname() failure */
	        return (-1); 
	}
	else
	{
		/* AF_INET socket */
		if ((result = sfcntl(fildes, cmd, arg)) != -1 && cmd == F_GETFL)
			result |= O_RDWR;  /* fill in some missing flags */
	        return result;
	}
}
Commit	Line	Data
feb33499 JH	1
	2	/*
	3	* gcc long pointer support code for HPPA.
	4	* Copyright 1998, DIS International, Ltd.
c72515e3 JH	5	* This code is free software; you may redistribute it and/or modify
	6	* it under the same terms as Perl itself. (Relicensed for Perl in
	7	* in April 2002 by Mark Klein.)
feb33499 JH	8	*/
	9	typedef struct {
	10	int spaceid;
	11	unsigned int offset;
	12	} LONGPOINTER, longpointer;
	13
	14	/*
	15	* gcc long pointer support code for HPPA.
	16	* Copyright 1998, DIS International, Ltd.
c72515e3 JH	17	* This code is free software; you may redistribute it and/or modify
	18	* it under the same terms as Perl itself. (Relicensed for Perl in
	19	* in April 2002 by Mark Klein.)
feb33499 JH	20	*/
	21
	22	int __perl_mpe_getspaceid(void *source)
	23	{
	24	int val;
	25	/*
	26	* Given the short pointer, determine it's space ID.
	27	*/
	28
	29	/*
	30	* The colons separate output from input parameters. In this case,
	31	* the output of the instruction (output indicated by the "=" in the
	32	* constraint) is to a memory location (indicated by the "m"). The
	33	* input constraint indicates that the source to the instruction
	34	* is a register reference (indicated by the "r").
	35	* The general format is:
	36	* asm("<instruction template>" : <output> : <input> : <clobbers>);
	37	* where <output> and <input> are:
	38	* "<constraint>" (<token>)
	39	* <instruction template> is the PA-RISC instruction in template fmt.
	40	* <clobbers> indicates those registers clobbered by the instruction
	41	* and provides hints to the optimizer.
	42	*
	43	* Refer to the gcc documentation or http://www.dis.com/gnu/gcc_toc.html
	44	*/
4cbfc073 JH	45	__asm__ __volatile__ (
	46	" comiclr,= 0,%1,%%r28\n"
	47	"\t ldsid (%%r0,%1),%%r28\n"
	48	"\t stw %%r28, %0"
feb33499 JH	49	: "=m" (val) // Output to val
	50	: "r" (source) // Source must be gen reg
	51	: "%r28"); // Clobbers %r28
	52	return (val);
	53	};
	54
	55	LONGPOINTER __perl_mpe_longaddr(void *source)
	56	{
	57	LONGPOINTER lptr;
	58	/*
	59	* Return the long pointer for the address in sr5 space.
	60	*/
	61
4cbfc073 JH	62	__asm__ __volatile__ (
	63	" comiclr,= 0,%2,%%r28\n"
	64	"\t ldsid (%%r0,%2),%%r28\n"
	65	"\t stw %%r28, %0\n"
	66	"\t stw %2, %1"
feb33499 JH	67	: "=m" (lptr.spaceid),
	68	"=m" (lptr.offset) // Store to lptr
	69	: "r" (source) // Source must be gen reg
	70	: "%r28"); // Clobbers %r28
	71	return (lptr);
	72	};
	73
	74	LONGPOINTER __perl_mpe_addtopointer(LONGPOINTER source, // %r26 == source offset
	75	// %r25 == source space
	76	int len) // %r24 == length in bytes
	77	{
	78	/*
	79	* Increment a longpointer.
	80	*/
	81
4cbfc073 JH	82	__asm__ __volatile__ (
	83	" copy %0,%%r28\n" // copy space to r28
	84	"\t add %1,%2,%%r29" // Increment the pointer
feb33499 JH	85	: // No output
	86	: "r" (source.spaceid), // Source address
	87	"r" (source.offset),
	88	"r" (len) // Length
	89	: "%r28", // Clobbers
	90	"%r29");
	91	};
	92
	93	void __perl_mpe_longmove(int len, // %r26 == byte length
	94	LONGPOINTER source, // %r23 == source space, %r24 == off
	95	LONGPOINTER target) // sp-#56 == target space, sp-#52== off
	96	{
	97	/*
	98	* Move data between two buffers in long pointer space.
	99	*/
	100
4cbfc073 JH	101	__asm__ __volatile__ (
	102	" .import $$lr_unk_unk_long,MILLICODE\n"
	103	"\t mtsp %0,%%sr1\n" // copy source space to sr1
	104	"\t copy %1,%%r26\n" // load source offset to r26
	105	"\t copy %4,%%r24\n" // load length to r24
	106	"\t copy %3,%%r25\n" // load target offset to r25
	107	"\t bl $$lr_unk_unk_long,%%r31\n" // start branch to millicode
	108	"\t mtsp %2,%%sr2" // copy target space to sr2
feb33499 JH	109	: // No output
	110	: "r" (source.spaceid), // Source address
	111	"r" (source.offset),
	112	"r" (target.spaceid), // Target address
	113	"r" (target.offset),
	114	"r" (len) // Byte length
	115	: "%r1", // Clobbers
	116	"%r24",
	117	"%r25",
	118	"%r26",
	119	"%r31");
	120	};
	121
	122	int __perl_mpe_longpeek(LONGPOINTER source)
	123	{
	124	/*
	125	* Fetch the int in long pointer space.
	126	*/
	127	unsigned int val;
	128
4cbfc073 JH	129	__asm__ __volatile__ (
	130	" mtsp %1, %%sr1\n"
	131	"\t copy %2, %%r28\n"
	132	"\t ldw 0(%%sr1, %%r28), %%r28\n"
	133	"\t stw %%r28, %0"
feb33499 JH	134	: "=m" (val) // Output val
	135	: "r" (source.spaceid), // Source space ID
	136	"r" (source.offset) // Source offset
	137	: "%r28"); // Clobbers %r28
	138
	139	return (val);
	140	};
	141
	142	void __perl_mpe_longpoke(LONGPOINTER target, // %r25 == spaceid, %r26 == offset
	143	unsigned int val) // %r24 == value
	144	{
	145	/*
	146	* Store the val into long pointer space.
	147	*/
4cbfc073 JH	148	__asm__ __volatile__ (
	149	" mtsp %0,%%sr1\n"
	150	"\t copy %1, %%r28\n"
	151	"\t stw %2, 0(%%sr1, %%r28)"
feb33499 JH	152	: // No output
	153	: "r" (target.spaceid), // Target space ID
	154	"r" (target.offset), // Target offset
	155	"r" (val) // Value to store
	156	: "%r28" // Clobbers %r28
	157	); // Copy space to %sr1
	158	};
	159
	160	void __perl_mpe_move_fast(int len, // %r26 == byte length
	161	void *source, // %r25 == source addr
	162	void *target) // %r24 == target addr
	163	{
	164	/*
	165	* Move using short pointers.
	166	*/
4cbfc073 JH	167	__asm__ __volatile__ (
	168	" .import $$lr_unk_unk,MILLICODE\n"
	169	"\t copy %1, %%r26\n" // Move source addr into pos
	170	"\t copy %2, %%r25\n" // Move target addr into pos
	171	"\t bl $$lr_unk_unk,%%r31\n" // Start branch to millicode
	172	"\t copy %0, %%r24" // Move length into position
feb33499 JH	173	: // No output
	174	: "r" (len), // Byte length
	175	"r" (source), // Source address
	176	"r" (target) // Target address
	177	: "%r24", // Clobbers
	178	"%r25",
	179	"%r26",
	180	"%r31");
	181	};
	182
	183	/*
	184	* ftruncate - set file size, BSD Style
	185	*
	186	* shortens or enlarges the file as neeeded
	187	* uses some undocumented locking call. It is known to work on SCO unix,
	188	* other vendors should try.
	189	* The #error directive prevents unsupported OSes
c72515e3 JH	190	*
	191	* ftruncate/truncate code by Mark Bixby.
	192	* This code is free software; you may redistribute it and/or modify
	193	* it under the same terms as Perl itself.
	194	*
feb33499 JH	195	*/
	196
	197	#include <unistd.h>
	198	#include <errno.h>
	199	#include <fcntl.h>
	200	#include <stdio.h>
	201	#include <mpe.h>
	202
	203	extern void FCONTROL(short, short, longpointer);
	204	extern void PRINTFILEINFO(int);
	205
	206	int ftruncate(int fd, long wantsize);
	207
	208	int ftruncate(int fd, long wantsize) {
	209
	210	int ccode_return,dummy=0;
	211
	212	if (lseek(fd, wantsize, SEEK_SET) < 0) {
	213	return (-1);
	214	}
	215
	216	FCONTROL(_mpe_fileno(fd),6,__perl_mpe_longaddr(&dummy)); /* Write new EOF */
	217	if ((ccode_return=ccode()) != CCE) {
	218	fprintf(stderr,"MPE ftruncate failed, ccode=%d, wantsize=%ld\n",ccode_return,wantsize);
	219	PRINTFILEINFO(_mpe_fileno(fd));
	220	errno = ESYSERR;
	221	return (-1);
	222	}
	223
	224	return (0);
	225	}
	226
	227	/*
	228	wrapper for truncate():
	229
	230	truncate() is UNIX, not POSIX.
	231
	232	This function requires ftruncate().
	233
	234
	235
	236	NAME
	237	truncate -
	238
	239	SYNOPSIS
	240	#include <unistd.h>
	241
	242	int truncate(const char *pathname, off_t length);
	243
	244	Returns: 0 if OK, -1 on error
	245
	246	from: Stevens' Advanced Programming in the UNIX Environment, p. 92
	247
	248
	249
	250	ERRORS
	251	EACCES
	252	EBADF
	253	EDQUOT (not POSIX) <- not implemented here
	254	EFAULT
	255	EINVAL
	256	EISDIR
	257	ELOOP (not POSIX) <- not implemented here
	258	ENAMETOOLONG
259	ENOTDIR
260	EROFS
261	ETXTBSY (not POSIX) <- not implemented here
262
263	from: HP-UX man page
264
265
266
267	Compile directives:
268	PRINT_ERROR - make this function print an error message to stderr
269	*/
270
271	#ifndef _POSIX_SOURCE
272	# define _POSIX_SOURCE
273	#endif
274
275	#include <sys/types.h> /* off_t, required by open() */
276	#include <sys/stat.h> /* required by open() */
277	#include <fcntl.h> /* open() */
278	#include <unistd.h> /* close() */
279	#include <stdio.h> /* perror(), sprintf() */
280
281
282
283	int
284	truncate(const char *pathname, off_t length)
285	{
286	int fd;
287	#ifdef PRINT_ERROR
288	char error_msg[80+1];
289	#endif
290
291	if (length == 0)
292	{
293	if ( (fd = open(pathname, O_WRONLY \| O_TRUNC)) < 0)
294	{
295	/* errno already set */
296	#ifdef PRINT_ERROR
297	sprintf(error_msg,
298	"truncate(): open(%s, O_WRONLY \| OTRUNC)\0",
299	pathname);
300	perror(error_msg);
301	#endif
302	return -1;
303	}
304	}
305	else
306	{
307	if ( (fd = open(pathname, O_WRONLY)) < 0)
308	{
309	/* errno already set */
310	#ifdef PRINT_ERROR
311	sprintf(error_msg,
312	"truncate(): open(%s, O_WRONLY)\0",
313	pathname);
314	perror(error_msg);
315	#endif
316	return -1;
317	}
318
319	if (ftruncate(fd, length) < 0)
320	{
321	/* errno already set */
322	#ifdef PRINT_ERROR
323	perror("truncate(): ftruncate()");
324	#endif
325	return -1;
326	}
327	}
328
329	if (close(fd) < 0)
330	{
331	/* errno already set */
332	#ifdef PRINT_ERROR
333	perror("truncate(): close()");
334	#endif
335	return -1;
336	}
337
338	return 0;
339	} /* truncate() */
340
341	/*
342	wrapper for gettimeofday():
343	gettimeofday() is UNIX, not POSIX.
344	gettimeofday() is a BSD function.
345
feb33499 JH	346	NAME
	347	gettimeofday -
	348
	349	SYNOPSIS
	350	#include <sys/time.h>
	351
	352	int gettimeofday(struct timeval tp, struct timezone tzp);
	353
	354	DESCRIPTION
	355	This function returns seconds and microseconds since midnight
	356	January 1, 1970. The microseconds is actually only accurate to
	357	the millisecond.
	358
	359	Note: To pick up the definitions of structs timeval and timezone
	360	from the <time.h> include file, the directive
	361	_SOCKET_SOURCE must be used.
	362
	363	RETURN VALUE
	364	A 0 return value indicates that the call succeeded. A -1 return
	365	value indicates an error occurred; errno is set to indicate the
	366	error.
	367
	368	ERRORS
	369	EFAULT not implemented
	370
	371	Changes:
	372	2-91 DR. Created.
	373	*/
	374
	375
	376	/* need _SOCKET_SOURCE to pick up structs timeval and timezone in time.h */
	377	#ifndef _SOCKET_SOURCE
	378	# define _SOCKET_SOURCE
	379	#endif
	380
	381	#include <time.h> /* structs timeval & timezone,
	382	difftime(), localtime(), mktime(), time() */
	383	#include <sys/time.h> /* gettimeofday() */
	384
	385	extern int TIMER();
	386
c72515e3 JH	387	/*
	388	* gettimeofday code by Mark Bixby.
	389	* This code is free software; you may redistribute it and/or modify
	390	* it under the same terms as Perl itself.
	391	*/
feb33499 JH	392
	393	#ifdef __STDC__
	394	int gettimeofday( struct timeval tp, struct timezone tpz )
	395	#else
	396	int gettimeofday( tp, tpz )
	397	struct timeval *tp;
	398	struct timezone *tpz;
	399	#endif
	400	{
	401	static unsigned long basetime = 0;
	402	static int dsttime = 0;
	403	static int minuteswest = 0;
	404	static int oldtime = 0;
	405	register int newtime;
	406
	407
	408	/-------------------------------------------------------------------/
	409	/* Setup a base from which all future time will be computed. */
	410	/-------------------------------------------------------------------/
	411	if ( basetime == 0 )
	412	{
	413	time_t gmt_time;
	414	time_t loc_time;
	415	struct tm *loc_time_tm;
	416
	417	gmt_time = time( NULL );
	418	loc_time_tm = localtime( &gmt_time ) ;
	419	loc_time = mktime( loc_time_tm );
	420
	421	oldtime = TIMER();
	422	basetime = (unsigned long) ( loc_time - (oldtime/1000) );
	423
	424	/----------------------------------------------------------------/
	425	/* The calling process must be restarted if timezone or dst */
	426	/* changes. */
	427	/----------------------------------------------------------------/
	428	minuteswest = (int) (difftime( loc_time, gmt_time ) / 60);
	429	dsttime = loc_time_tm->tm_isdst;
	430	}
	431
	432	/-------------------------------------------------------------------/
	433	/* Get the new time value. The timer value rolls over every 24 days, */
	434	/* so if the delta is negative, the basetime value is adjusted. */
	435	/-------------------------------------------------------------------/
	436	newtime = TIMER();
	437	if ( newtime < oldtime ) basetime += 2073600;
	438	oldtime = newtime;
	439
	440	/-------------------------------------------------------------------/
	441	/* Return the timestamp info. */
	442	/-------------------------------------------------------------------/
	443	tp->tv_sec = basetime + newtime/1000;
	444	tp->tv_usec = (newtime%1000) * 1000; /* only accurate to milli */
	445	if (tpz)
	446	{
	447	tpz->tz_minuteswest = minuteswest;
	448	tpz->tz_dsttime = dsttime;
	449	}
	450
	451	return 0;
	452
	453	} /* gettimeofday() */
b606c525 JH	454
	455	/*
	456	** MPE_FCNTL -- shadow function for fcntl()
	457	**
	458	** MPE requires sfcntl() for sockets, and fcntl() for everything
	459	** else. This shadow routine determines the descriptor type and
	460	** makes the appropriate call.
	461	**
	462	** Parameters:
	463	** same as fcntl().
	464	**
	465	** Returns:
	466	** same as fcntl().
	467	*/
	468
	469	#include <stdarg.h>
	470	#include <sys/socket.h>
	471
	472	int
	473	mpe_fcntl(int fildes, int cmd, ...)
	474	{
	475	int len, result;
	476	struct sockaddr sa;
	477
	478	void *arg;
	479	va_list ap;
	480
	481	va_start(ap, cmd);
	482	arg = va_arg(ap, void *);
	483	va_end(ap);
	484
	485	len = sizeof sa;
	486	if (getsockname(fildes, &sa, &len) == -1)
	487	{
	488	if (errno == EAFNOSUPPORT)
	489	/* AF_UNIX socket */
	490	return sfcntl(fildes, cmd, arg);
	491
	492	if (errno == ENOTSOCK)
	493	/* file or pipe */
	494	return fcntl(fildes, cmd, arg);
	495
	496	/* unknown getsockname() failure */
	497	return (-1);
	498	}
	499	else
	500	{
	501	/* AF_INET socket */
	502	if ((result = sfcntl(fildes, cmd, arg)) != -1 && cmd == F_GETFL)
	503	result \|= O_RDWR; /* fill in some missing flags */
	504	return result;
	505	}
	506	}