comparison src/editfns.c @ 30480:5ef94127f946

new function: float-time

30479:bc0a97df8aed

  /* If the user name claimed in the environment vars differs from
     the real uid, use the claimed name to find the full name.  */
  tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
  Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
				     : Vuser_login_name);
  
  p = (unsigned char *) getenv ("NAME");
  if (p)
    Vuser_full_name = build_string (p);
  else if (NILP (Vuser_full_name))
    Vuser_full_name = build_string ("unknown");

			  == current_buffer);

  return Fcons (Fpoint_marker (),
		Fcons (Fcopy_marker (current_buffer->mark, Qnil),
		       Fcons (visible ? Qt : Qnil,
			      current_buffer->mark_active)));		       
}

Lisp_Object
save_excursion_restore (info)
     Lisp_Object info;

  else
    {
      CHECK_NUMBER_COERCE_MARKER (pos, 0);
      if (XINT (pos) < BEGV || XINT (pos) >= ZV)
	return Qnil;
      
      pos_byte = CHAR_TO_BYTE (XINT (pos));
    }

  return make_number (FETCH_CHAR (pos_byte));
}

  register unsigned char *p, *q;
  extern char *index ();
  Lisp_Object full;

  if (NILP (uid))
    return Vuser_full_name; 
  else if (NUMBERP (uid))
    pw = (struct passwd *) getpwuid (XINT (uid));
  else if (STRINGP (uid)) 
    pw = (struct passwd *) getpwnam (XSTRING (uid)->data);
  else
    error ("Invalid UID specification");

  if (!pw)
    return Qnil;
  
  p = (unsigned char *) USER_FULL_NAME;
  /* Chop off everything after the first comma. */
  q = (unsigned char *) index (p, ',');
  full = make_string (p, q ? q - p : strlen (p));
  
#ifdef AMPERSAND_FULL_NAME
  p = XSTRING (full)->data;
  q = (unsigned char *) index (p, '&');
  /* Substitute the login name for the &, upcasing the first character.  */
  if (q)

  return Flist (3, result);
}


static int
lisp_time_argument (specified_time, result)
     Lisp_Object specified_time;
     time_t *result;
{
  if (NILP (specified_time))
    return time (result) != -1;
  else
    {
      Lisp_Object high, low;
      high = Fcar (specified_time);
      CHECK_NUMBER (high, 0);
      low = Fcdr (specified_time);
      if (CONSP (low))
	low = Fcar (low);
      CHECK_NUMBER (low, 0);
      *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
      return *result >> 16 == XINT (high);
    }
}

/* Write information into buffer S of size MAXSIZE, according to the
   FORMAT of length FORMAT_LEN, using time information taken from *TP.
   Default to Universal Time if UT is nonzero, local time otherwise.

  struct tm *tm;
  int ut = ! NILP (universal);

  CHECK_STRING (format_string, 1);

  if (! lisp_time_argument (time, &value))
    error ("Invalid time specification");

  format_string = code_convert_string_norecord (format_string,
						Vlocale_coding_system, 1);

{
  time_t time_spec;
  struct tm save_tm;
  struct tm *decoded_time;
  Lisp_Object list_args[9];
  
  if (! lisp_time_argument (specified_time, &time_spec))
    error ("Invalid time specification");

  decoded_time = localtime (&time_spec);
  if (! decoded_time)
    error ("Specified time is not representable");

  else
    {
      char tzbuf[100];
      char *tzstring;
      char **oldenv = environ, **newenv;
      
      if (EQ (zone, Qt))
	tzstring = "UTC0";
      else if (STRINGP (zone))
	tzstring = (char *) XSTRING (zone)->data;
      else if (INTEGERP (zone))

	  tzstring = tzbuf;
	}
      else
	error ("Invalid time zone specification");

      /* Set TZ before calling mktime; merely adjusting mktime's returned 
	 value doesn't suffice, since that would mishandle leap seconds.  */
      set_time_zone_rule (tzstring);

      time = mktime (&tm);

{
  time_t value;
  char buf[30];
  register char *tem;

  if (! lisp_time_argument (specified_time, &value))
    value = -1;
  tem = (char *) ctime (&value);

  strncpy (buf, tem, 24);
  buf[24] = 0;

{
  time_t value;
  struct tm *t;
  struct tm gmt;

  if (lisp_time_argument (specified_time, &value)
      && (t = gmtime (&value)) != 0
      && (gmt = *t, t = localtime (&value)) != 0)
    {
      int offset = tm_diff (t, &gmt);
      char *s = 0;

#ifdef LOCALTIME_CACHE

/* These two values are known to load tz files in buggy implementations,
   i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
   Their values shouldn't matter in non-buggy implementations.
   We don't use string literals for these strings, 
   since if a string in the environment is in readonly
   storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
   See Sun bugs 1113095 and 1114114, ``Timezone routines
   improperly modify environment''.  */

		    current_buffer->auto_save_modified++;
		}
	    }

	  /* Take care of the case where the new character
	     combines with neighboring bytes.  */ 
	  if (maybe_byte_combining
	      && (maybe_byte_combining == COMBINING_AFTER
		  ? (pos_byte_next < Z_BYTE
		     && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
		  : ((pos_byte_next < Z_BYTE

		   POS.  So, to cancel the later increment of POS,
		   decrease it now.  */
		pos--;
	      else
		INC_POS (pos_byte_next);
		
	      if (! NILP (noundo))
		current_buffer->undo_list = tem;

	      UNGCPRO;
	    }

	{
	  nc = tt[oc];
	  if (nc != oc)
	    {
	      /* Take care of the case where the new character
		 combines with neighboring bytes.  */ 
	      if (!ASCII_BYTE_P (nc)
		  && (CHAR_HEAD_P (nc)
		      ? ! CHAR_HEAD_P (FETCH_BYTE (pos_byte + 1))
		      : (pos_byte > BEG_BYTE
			 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte - 1)))))

  if ((nargs & 1) == 0 || nargs < 3)
    error ("Wrong number of arguments");

  properties = string = Qnil;
  GCPRO2 (properties, string);
  
  /* First argument must be a string.  */
  CHECK_STRING (args[0], 0);
  string = Fcopy_sequence (args[0]);

  for (i = 1; i < nargs; i += 2)

	    else
	      if (*format != 'd' && *format != 'o' && *format != 'x'
		  && *format != 'i' && *format != 'X' && *format != 'c')
		error ("Invalid format operation %%%c", *format);

	    thissize = 30;	
	    if (*format == 'c'
		&& (! SINGLE_BYTE_CHAR_P (XINT (args[n]))
		    || XINT (args[n]) == 0))
	      {
		if (! multibyte)

		goto retry;
	      }
	    args[n] = tem;
	    goto string;
	  }
	
	if (thissize < minlen)
	  thissize = minlen;

	total += thissize + 4;
      }

		    {
		      int nbytes = nargs * sizeof *info;
		      info = (struct info *) alloca (nbytes);
		      bzero (info, nbytes);
		    }
		  
		  info[n].start = start;
		  info[n].end = nchars;
		}
	    }
	  else if (INTEGERP (args[n]) || FLOATP (args[n]))

    xfree (buf);

  /* If the format string has text properties, or any of the string
     arguments has text properties, set up text properties of the
     result string.  */
  
  if (XSTRING (args[0])->intervals || info)
    {
      Lisp_Object len, new_len, props;
      struct gcpro gcpro1;
      
      /* Add text properties from the format string.  */
      len = make_number (XSTRING (args[0])->size);
      props = text_property_list (args[0], make_number (0), len, Qnil);
      GCPRO1 (props);
      
      if (CONSP (props))
	{
	  new_len = make_number (XSTRING (val)->size);
	  extend_property_ranges (props, len, new_len);
	  add_text_properties_from_list (val, props, make_number (0));

   START2_BYTE, END2_BYTE are the byte positions.

   Traverses the entire marker list of the buffer to do so, adding an
   appropriate amount to some, subtracting from some, and leaving the
   rest untouched.  Most of this is copied from adjust_markers in insdel.c.
  
   It's the caller's job to ensure that START1 <= END1 <= START2 <= END2.  */

void
transpose_markers (start1, end1, start2, end2,
		   start1_byte, end1_byte, start2_byte, end2_byte)

     the dirty work to Fmarker_position, below.  */

  /* The difference between the region's lengths */
  diff = (end2 - start2) - (end1 - start1);
  diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
  
  /* For shifting each marker in a region by the length of the other
     region plus the distance between the regions.  */
  amt1 = (end2 - start2) + (start2 - end1);
  amt2 = (end1 - start1) + (start2 - end1);
  amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);

  /* The possibilities are:
     1. Adjacent (contiguous) regions, or separate but equal regions
     (no, really equal, in this case!), or
     2. Separate regions of unequal size.
     
     The worst case is usually No. 2.  It means that (aside from
     potential need for getting the gap out of the way), there also
     needs to be a shifting of the text between the two regions.  So
     if they are spread far apart, we are that much slower... sigh.  */

functions if all the text being accessed has this property.");
  Vbuffer_access_fontified_property = Qnil;

  DEFVAR_LISP ("system-name", &Vsystem_name,
	       "The name of the machine Emacs is running on.");
  
  DEFVAR_LISP ("user-full-name", &Vuser_full_name,
	       "The full name of the user logged in.");

  DEFVAR_LISP ("user-login-name", &Vuser_login_name,
	       "The user's name, taken from environment variables if possible.");

  defsubr (&Suser_real_uid);
  defsubr (&Suser_full_name);
  defsubr (&Semacs_pid);
  defsubr (&Scurrent_time);
  defsubr (&Sformat_time_string);
  defsubr (&Sdecode_time);
  defsubr (&Sencode_time);
  defsubr (&Scurrent_time_string);
  defsubr (&Scurrent_time_zone);
  defsubr (&Sset_time_zone_rule);

30480:5ef94127f946

  /* If the user name claimed in the environment vars differs from
     the real uid, use the claimed name to find the full name.  */
  tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
  Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
				     : Vuser_login_name);

  p = (unsigned char *) getenv ("NAME");
  if (p)
    Vuser_full_name = build_string (p);
  else if (NILP (Vuser_full_name))
    Vuser_full_name = build_string ("unknown");

			  == current_buffer);

  return Fcons (Fpoint_marker (),
		Fcons (Fcopy_marker (current_buffer->mark, Qnil),
		       Fcons (visible ? Qt : Qnil,
			      current_buffer->mark_active)));
}

Lisp_Object
save_excursion_restore (info)
     Lisp_Object info;

  else
    {
      CHECK_NUMBER_COERCE_MARKER (pos, 0);
      if (XINT (pos) < BEGV || XINT (pos) >= ZV)
	return Qnil;

      pos_byte = CHAR_TO_BYTE (XINT (pos));
    }

  return make_number (FETCH_CHAR (pos_byte));
}

  register unsigned char *p, *q;
  extern char *index ();
  Lisp_Object full;

  if (NILP (uid))
    return Vuser_full_name;
  else if (NUMBERP (uid))
    pw = (struct passwd *) getpwuid (XINT (uid));
  else if (STRINGP (uid))
    pw = (struct passwd *) getpwnam (XSTRING (uid)->data);
  else
    error ("Invalid UID specification");

  if (!pw)
    return Qnil;

  p = (unsigned char *) USER_FULL_NAME;
  /* Chop off everything after the first comma. */
  q = (unsigned char *) index (p, ',');
  full = make_string (p, q ? q - p : strlen (p));

#ifdef AMPERSAND_FULL_NAME
  p = XSTRING (full)->data;
  q = (unsigned char *) index (p, '&');
  /* Substitute the login name for the &, upcasing the first character.  */
  if (q)

  return Flist (3, result);
}


static int
lisp_time_argument (specified_time, result, usec)
     Lisp_Object specified_time;
     time_t *result;
     int *usec;
{
  if (NILP (specified_time))
    {
      if (usec)
        {
          EMACS_TIME t;

          if (-1 == EMACS_GET_TIME (t))
            return 0;
          *usec = EMACS_USECS (t);
          *result = EMACS_SECS (t);
          return 1;
        }
      else
        return time (result) != -1;
    }
  else
    {
      Lisp_Object high, low;
      high = Fcar (specified_time);
      CHECK_NUMBER (high, 0);
      low = Fcdr (specified_time);
      if (CONSP (low))
        {
          if (usec)
            {
              Lisp_Object usec_l = Fcdr (low);
              if (CONSP (usec_l))
                usec_l = Fcar (usec_l);
              if (NILP (usec_l))
                *usec = 0;
              else
                {
                  CHECK_NUMBER (usec_l, 0);
                  *usec = XINT (usec_l);
                }
            }
          low = Fcar (low);
        }
      else if (usec)
        *usec = 0;
      CHECK_NUMBER (low, 0);
      *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
      return *result >> 16 == XINT (high);
    }
}

DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
  "Return the current time, as a float number of seconds since the epoch.\n\
If an argument is given, it specifies a time to convert to float\n\
instead of the current time.  The argument should have the forms:\n\
 (HIGH . LOW) or (HIGH LOW USEC) or (HIGH LOW . USEC).\n\
Thus, you can use times obtained from `current-time'\n\
and from `file-attributes'.")
  (specified_time)
     Lisp_Object specified_time;
{
  time_t sec;
  int usec;

  if (! lisp_time_argument (specified_time, &sec, &usec))
    error ("Invalid time specification");

  return make_float (sec + usec * 0.0000001);
}

/* Write information into buffer S of size MAXSIZE, according to the
   FORMAT of length FORMAT_LEN, using time information taken from *TP.
   Default to Universal Time if UT is nonzero, local time otherwise.

  struct tm *tm;
  int ut = ! NILP (universal);

  CHECK_STRING (format_string, 1);

  if (! lisp_time_argument (time, &value, NULL))
    error ("Invalid time specification");

  format_string = code_convert_string_norecord (format_string,
						Vlocale_coding_system, 1);

{
  time_t time_spec;
  struct tm save_tm;
  struct tm *decoded_time;
  Lisp_Object list_args[9];

  if (! lisp_time_argument (specified_time, &time_spec, NULL))
    error ("Invalid time specification");

  decoded_time = localtime (&time_spec);
  if (! decoded_time)
    error ("Specified time is not representable");

  else
    {
      char tzbuf[100];
      char *tzstring;
      char **oldenv = environ, **newenv;

      if (EQ (zone, Qt))
	tzstring = "UTC0";
      else if (STRINGP (zone))
	tzstring = (char *) XSTRING (zone)->data;
      else if (INTEGERP (zone))

	  tzstring = tzbuf;
	}
      else
	error ("Invalid time zone specification");

      /* Set TZ before calling mktime; merely adjusting mktime's returned
	 value doesn't suffice, since that would mishandle leap seconds.  */
      set_time_zone_rule (tzstring);

      time = mktime (&tm);

{
  time_t value;
  char buf[30];
  register char *tem;

  if (! lisp_time_argument (specified_time, &value, NULL))
    value = -1;
  tem = (char *) ctime (&value);

  strncpy (buf, tem, 24);
  buf[24] = 0;

{
  time_t value;
  struct tm *t;
  struct tm gmt;

  if (lisp_time_argument (specified_time, &value, NULL)
      && (t = gmtime (&value)) != 0
      && (gmt = *t, t = localtime (&value)) != 0)
    {
      int offset = tm_diff (t, &gmt);
      char *s = 0;

#ifdef LOCALTIME_CACHE

/* These two values are known to load tz files in buggy implementations,
   i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
   Their values shouldn't matter in non-buggy implementations.
   We don't use string literals for these strings,
   since if a string in the environment is in readonly
   storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
   See Sun bugs 1113095 and 1114114, ``Timezone routines
   improperly modify environment''.  */

		    current_buffer->auto_save_modified++;
		}
	    }

	  /* Take care of the case where the new character
	     combines with neighboring bytes.  */
	  if (maybe_byte_combining
	      && (maybe_byte_combining == COMBINING_AFTER
		  ? (pos_byte_next < Z_BYTE
		     && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
		  : ((pos_byte_next < Z_BYTE

		   POS.  So, to cancel the later increment of POS,
		   decrease it now.  */
		pos--;
	      else
		INC_POS (pos_byte_next);

	      if (! NILP (noundo))
		current_buffer->undo_list = tem;

	      UNGCPRO;
	    }

	{
	  nc = tt[oc];
	  if (nc != oc)
	    {
	      /* Take care of the case where the new character
		 combines with neighboring bytes.  */
	      if (!ASCII_BYTE_P (nc)
		  && (CHAR_HEAD_P (nc)
		      ? ! CHAR_HEAD_P (FETCH_BYTE (pos_byte + 1))
		      : (pos_byte > BEG_BYTE
			 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte - 1)))))

  if ((nargs & 1) == 0 || nargs < 3)
    error ("Wrong number of arguments");

  properties = string = Qnil;
  GCPRO2 (properties, string);

  /* First argument must be a string.  */
  CHECK_STRING (args[0], 0);
  string = Fcopy_sequence (args[0]);

  for (i = 1; i < nargs; i += 2)

	    else
	      if (*format != 'd' && *format != 'o' && *format != 'x'
		  && *format != 'i' && *format != 'X' && *format != 'c')
		error ("Invalid format operation %%%c", *format);

	    thissize = 30;
	    if (*format == 'c'
		&& (! SINGLE_BYTE_CHAR_P (XINT (args[n]))
		    || XINT (args[n]) == 0))
	      {
		if (! multibyte)

		goto retry;
	      }
	    args[n] = tem;
	    goto string;
	  }

	if (thissize < minlen)
	  thissize = minlen;

	total += thissize + 4;
      }

		    {
		      int nbytes = nargs * sizeof *info;
		      info = (struct info *) alloca (nbytes);
		      bzero (info, nbytes);
		    }

		  info[n].start = start;
		  info[n].end = nchars;
		}
	    }
	  else if (INTEGERP (args[n]) || FLOATP (args[n]))

    xfree (buf);

  /* If the format string has text properties, or any of the string
     arguments has text properties, set up text properties of the
     result string.  */

  if (XSTRING (args[0])->intervals || info)
    {
      Lisp_Object len, new_len, props;
      struct gcpro gcpro1;

      /* Add text properties from the format string.  */
      len = make_number (XSTRING (args[0])->size);
      props = text_property_list (args[0], make_number (0), len, Qnil);
      GCPRO1 (props);

      if (CONSP (props))
	{
	  new_len = make_number (XSTRING (val)->size);
	  extend_property_ranges (props, len, new_len);
	  add_text_properties_from_list (val, props, make_number (0));

   START2_BYTE, END2_BYTE are the byte positions.

   Traverses the entire marker list of the buffer to do so, adding an
   appropriate amount to some, subtracting from some, and leaving the
   rest untouched.  Most of this is copied from adjust_markers in insdel.c.

   It's the caller's job to ensure that START1 <= END1 <= START2 <= END2.  */

void
transpose_markers (start1, end1, start2, end2,
		   start1_byte, end1_byte, start2_byte, end2_byte)

     the dirty work to Fmarker_position, below.  */

  /* The difference between the region's lengths */
  diff = (end2 - start2) - (end1 - start1);
  diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);

  /* For shifting each marker in a region by the length of the other
     region plus the distance between the regions.  */
  amt1 = (end2 - start2) + (start2 - end1);
  amt2 = (end1 - start1) + (start2 - end1);
  amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);

  /* The possibilities are:
     1. Adjacent (contiguous) regions, or separate but equal regions
     (no, really equal, in this case!), or
     2. Separate regions of unequal size.

     The worst case is usually No. 2.  It means that (aside from
     potential need for getting the gap out of the way), there also
     needs to be a shifting of the text between the two regions.  So
     if they are spread far apart, we are that much slower... sigh.  */

functions if all the text being accessed has this property.");
  Vbuffer_access_fontified_property = Qnil;

  DEFVAR_LISP ("system-name", &Vsystem_name,
	       "The name of the machine Emacs is running on.");

  DEFVAR_LISP ("user-full-name", &Vuser_full_name,
	       "The full name of the user logged in.");

  DEFVAR_LISP ("user-login-name", &Vuser_login_name,
	       "The user's name, taken from environment variables if possible.");

  defsubr (&Suser_real_uid);
  defsubr (&Suser_full_name);
  defsubr (&Semacs_pid);
  defsubr (&Scurrent_time);
  defsubr (&Sformat_time_string);
  defsubr (&Sfloat_time);
  defsubr (&Sdecode_time);
  defsubr (&Sencode_time);
  defsubr (&Scurrent_time_string);
  defsubr (&Scurrent_time_zone);
  defsubr (&Sset_time_zone_rule);