1: /* Lisp functions pertaining to editing.
    2:    Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996,
    3:                  1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
    4:                  2005, 2006, 2007 Free Software Foundation, Inc.
    5: 
    6: This file is part of GNU Emacs.
    7: 
    8: GNU Emacs is free software; you can redistribute it and/or modify
    9: it under the terms of the GNU General Public License as published by
   10: the Free Software Foundation; either version 2, or (at your option)
   11: any later version.
   12: 
   13: GNU Emacs is distributed in the hope that it will be useful,
   14: but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: GNU General Public License for more details.
   17: 
   18: You should have received a copy of the GNU General Public License
   19: along with GNU Emacs; see the file COPYING.  If not, write to
   20: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   21: Boston, MA 02110-1301, USA.  */
   22: 
   23: 
   24: #include <config.h>
   25: #include <sys/types.h>
   26: #include <stdio.h>
   27: 
   28: #ifdef HAVE_PWD_H
   29: #include <pwd.h>
   30: #endif
   31: 
   32: #ifdef HAVE_UNISTD_H
   33: #include <unistd.h>
   34: #endif
   35: 
   36: #ifdef HAVE_SYS_UTSNAME_H
   37: #include <sys/utsname.h>
   38: #endif
   39: 
   40: #include "lisp.h"
   41: 
   42: /* systime.h includes <sys/time.h> which, on some systems, is required
   43:    for <sys/resource.h>; thus systime.h must be included before
   44:    <sys/resource.h> */
   45: #include "systime.h"
   46: 
   47: #if defined HAVE_SYS_RESOURCE_H
   48: #include <sys/resource.h>
   49: #endif
   50: 
   51: #include <ctype.h>
   52: 
   53: #include "intervals.h"
   54: #include "buffer.h"
   55: #include "charset.h"
   56: #include "coding.h"
   57: #include "frame.h"
   58: #include "window.h"
   59: #include "blockinput.h"
   60: 
   61: #ifdef STDC_HEADERS
   62: #include <float.h>
   63: #define MAX_10_EXP      DBL_MAX_10_EXP
   64: #else
   65: #define MAX_10_EXP      310
   66: #endif
   67: 
   68: #ifndef NULL
   69: #define NULL 0
   70: #endif
   71: 
   72: #ifndef USE_CRT_DLL
   73: extern char **environ;
   74: #endif
   75: 
   76: #define TM_YEAR_BASE 1900
   77: 
   78: /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
   79:    asctime to have well-defined behavior.  */
   80: #ifndef TM_YEAR_IN_ASCTIME_RANGE
   81: # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
   82:     (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
   83: #endif
   84: 
   85: extern size_t emacs_strftimeu P_ ((char *, size_t, const char *,
   86:                                    const struct tm *, int));
   87: static int tm_diff P_ ((struct tm *, struct tm *));
   88: static void find_field P_ ((Lisp_Object, Lisp_Object, Lisp_Object, int *, Lisp_Object, int *));
   89: static void update_buffer_properties P_ ((int, int));
   90: static Lisp_Object region_limit P_ ((int));
   91: int lisp_time_argument P_ ((Lisp_Object, time_t *, int *));
   92: static size_t emacs_memftimeu P_ ((char *, size_t, const char *,
   93:                                    size_t, const struct tm *, int));
   94: static void general_insert_function P_ ((void (*) (const unsigned char *, int),
   95:                                          void (*) (Lisp_Object, int, int, int,
   96:                                                    int, int),
   97:                                          int, int, Lisp_Object *));
   98: static Lisp_Object subst_char_in_region_unwind P_ ((Lisp_Object));
   99: static Lisp_Object subst_char_in_region_unwind_1 P_ ((Lisp_Object));
  100: static void transpose_markers P_ ((int, int, int, int, int, int, int, int));
  101: 
  102: #ifdef HAVE_INDEX
  103: extern char *index P_ ((const char *, int));
  104: #endif
  105: 
  106: Lisp_Object Vbuffer_access_fontify_functions;
  107: Lisp_Object Qbuffer_access_fontify_functions;
  108: Lisp_Object Vbuffer_access_fontified_property;
  109: 
  110: Lisp_Object Fuser_full_name P_ ((Lisp_Object));
  111: 
  112: /* Non-nil means don't stop at field boundary in text motion commands.  */
  113: 
  114: Lisp_Object Vinhibit_field_text_motion;
  115: 
  116: /* Some static data, and a function to initialize it for each run */
  117: 
  118: Lisp_Object Vsystem_name;
  119: Lisp_Object Vuser_real_login_name;      /* login name of current user ID */
  120: Lisp_Object Vuser_full_name;            /* full name of current user */
  121: Lisp_Object Vuser_login_name;           /* user name from LOGNAME or USER */
  122: Lisp_Object Voperating_system_release;  /* Operating System Release */
  123: 
  124: /* Symbol for the text property used to mark fields.  */
  125: 
  126: Lisp_Object Qfield;
  127: 
  128: /* A special value for Qfield properties.  */
  129: 
  130: Lisp_Object Qboundary;
  131: 
  132: 
  133: void
  134: init_editfns ()
  135: {
  136:   char *user_name;
  137:   register unsigned char *p;
  138:   struct passwd *pw;    /* password entry for the current user */
  139:   Lisp_Object tem;
  140: 
  141:   /* Set up system_name even when dumping.  */
  142:   init_system_name ();
  143: 
  144: #ifndef CANNOT_DUMP
  145:   /* Don't bother with this on initial start when just dumping out */
  146:   if (!initialized)
  147:     return;
  148: #endif /* not CANNOT_DUMP */
  149: 
  150:   pw = (struct passwd *) getpwuid (getuid ());
  151: #ifdef MSDOS
  152:   /* We let the real user name default to "root" because that's quite
  153:      accurate on MSDOG and because it lets Emacs find the init file.
  154:      (The DVX libraries override the Djgpp libraries here.)  */
  155:   Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
  156: #else
  157:   Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
  158: #endif
  159: 
  160:   /* Get the effective user name, by consulting environment variables,
  161:      or the effective uid if those are unset.  */
  162:   user_name = (char *) getenv ("LOGNAME");
  163:   if (!user_name)
  164: #ifdef WINDOWSNT
  165:     user_name = (char *) getenv ("USERNAME");   /* it's USERNAME on NT */
  166: #else  /* WINDOWSNT */
  167:     user_name = (char *) getenv ("USER");
  168: #endif /* WINDOWSNT */
  169:   if (!user_name)
  170:     {
  171:       pw = (struct passwd *) getpwuid (geteuid ());
  172:       user_name = (char *) (pw ? pw->pw_name : "unknown");
  173:     }
  174:   Vuser_login_name = build_string (user_name);
  175: 
  176:   /* If the user name claimed in the environment vars differs from
  177:      the real uid, use the claimed name to find the full name.  */
  178:   tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
  179:   Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
  180:                                      : Vuser_login_name);
  181: 
  182:   p = (unsigned char *) getenv ("NAME");
  183:   if (p)
  184:     Vuser_full_name = build_string (p);
  185:   else if (NILP (Vuser_full_name))
  186:     Vuser_full_name = build_string ("unknown");
  187: 
  188: #ifdef HAVE_SYS_UTSNAME_H
  189:   {
  190:     struct utsname uts;
  191:     uname (&uts);
  192:     Voperating_system_release = build_string (uts.release);
  193:   }
  194: #else
  195:   Voperating_system_release = Qnil;
  196: #endif
  197: }
  198: ^L
  199: DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
  200:        doc: /* Convert arg CHAR to a string containing that character.
  201: usage: (char-to-string CHAR)  */)
  202:      (character)
  203:      Lisp_Object character;
  204: {
  205:   int len;
  206:   unsigned char str[MAX_MULTIBYTE_LENGTH];
  207: 
  208:   CHECK_NUMBER (character);
  209: 
  210:   len = (SINGLE_BYTE_CHAR_P (XFASTINT (character))
  211:          ? (*str = (unsigned char)(XFASTINT (character)), 1)
  212:          : char_to_string (XFASTINT (character), str));
  213:   return make_string_from_bytes (str, 1, len);
  214: }
  215: 
  216: DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
  217:        doc: /* Convert arg STRING to a character, the first character of that string.
  218: A multibyte character is handled correctly.  */)
  219:      (string)
  220:      register Lisp_Object string;
  221: {
  222:   register Lisp_Object val;
  223:   CHECK_STRING (string);
  224:   if (SCHARS (string))
  225:     {
  226:       if (STRING_MULTIBYTE (string))
  227:         XSETFASTINT (val, STRING_CHAR (SDATA (string), SBYTES (string)));
  228:       else
  229:         XSETFASTINT (val, SREF (string, 0));
  230:     }
  231:   else
  232:     XSETFASTINT (val, 0);
  233:   return val;
  234: }
  235: ^L
  236: static Lisp_Object
  237: buildmark (charpos, bytepos)
  238:      int charpos, bytepos;
  239: {
  240:   register Lisp_Object mark;
  241:   mark = Fmake_marker ();
  242:   set_marker_both (mark, Qnil, charpos, bytepos);
  243:   return mark;
  244: }
  245: 
  246: DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
  247:        doc: /* Return value of point, as an integer.
  248: Beginning of buffer is position (point-min).  */)
  249:      ()
  250: {
  251:   Lisp_Object temp;
  252:   XSETFASTINT (temp, PT);
  253:   return temp;
  254: }
  255: 
  256: DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
  257:        doc: /* Return value of point, as a marker object.  */)
  258:      ()
  259: {
  260:   return buildmark (PT, PT_BYTE);
  261: }
  262: 
  263: int
  264: clip_to_bounds (lower, num, upper)
  265:      int lower, num, upper;
  266: {
  267:   if (num < lower)
  268:     return lower;
  269:   else if (num > upper)
  270:     return upper;
  271:   else
  272:     return num;
  273: }
  274: 
  275: DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
  276:        doc: /* Set point to POSITION, a number or marker.
  277: Beginning of buffer is position (point-min), end is (point-max).
  278: 
  279: The return value is POSITION.  */)
  280:      (position)
  281:      register Lisp_Object position;
  282: {
  283:   int pos;
  284: 
  285:   if (MARKERP (position)
  286:       && current_buffer == XMARKER (position)->buffer)
  287:     {
  288:       pos = marker_position (position);
  289:       if (pos < BEGV)
  290:         SET_PT_BOTH (BEGV, BEGV_BYTE);
  291:       else if (pos > ZV)
  292:         SET_PT_BOTH (ZV, ZV_BYTE);
  293:       else
  294:         SET_PT_BOTH (pos, marker_byte_position (position));
  295: 
  296:       return position;
  297:     }
  298: 
  299:   CHECK_NUMBER_COERCE_MARKER (position);
  300: 
  301:   pos = clip_to_bounds (BEGV, XINT (position), ZV);
  302:   SET_PT (pos);
  303:   return position;
  304: }
  305: 
  306: 
  307: /* Return the start or end position of the region.
  308:    BEGINNINGP non-zero means return the start.
  309:    If there is no region active, signal an error. */
  310: 
  311: static Lisp_Object
  312: region_limit (beginningp)
  313:      int beginningp;
  314: {
  315:   extern Lisp_Object Vmark_even_if_inactive; /* Defined in callint.c. */
  316:   Lisp_Object m;
  317: 
  318:   if (!NILP (Vtransient_mark_mode)
  319:       && NILP (Vmark_even_if_inactive)
  320:       && NILP (current_buffer->mark_active))
  321:     xsignal0 (Qmark_inactive);
  322: 
  323:   m = Fmarker_position (current_buffer->mark);
  324:   if (NILP (m))
  325:     error ("The mark is not set now, so there is no region");
  326: 
  327:   if ((PT < XFASTINT (m)) == (beginningp != 0))
  328:     m = make_number (PT);
  329:   return m;
  330: }
  331: 
  332: DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
  333:        doc: /* Return position of beginning of region, as an integer.  */)
  334:      ()
  335: {
  336:   return region_limit (1);
  337: }
  338: 
  339: DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
  340:        doc: /* Return position of end of region, as an integer.  */)
  341:      ()
  342: {
  343:   return region_limit (0);
  344: }
  345: 
  346: DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
  347:        doc: /* Return this buffer's mark, as a marker object.
  348: Watch out!  Moving this marker changes the mark position.
  349: If you set the marker not to point anywhere, the buffer will have no mark.  */)
  350:      ()
  351: {
  352:   return current_buffer->mark;
  353: }
  354: 
  355: ^L
  356: /* Find all the overlays in the current buffer that touch position POS.
  357:    Return the number found, and store them in a vector in VEC
  358:    of length LEN.  */
  359: 
  360: static int
  361: overlays_around (pos, vec, len)
  362:      int pos;
  363:      Lisp_Object *vec;
  364:      int len;
  365: {
  366:   Lisp_Object overlay, start, end;
  367:   struct Lisp_Overlay *tail;
  368:   int startpos, endpos;
  369:   int idx = 0;
  370: 
  371:   for (tail = current_buffer->overlays_before; tail; tail = tail->next)
  372:     {
  373:       XSETMISC (overlay, tail);
  374: 
  375:       end = OVERLAY_END (overlay);
  376:       endpos = OVERLAY_POSITION (end);
  377:       if (endpos < pos)
  378:           break;
  379:       start = OVERLAY_START (overlay);
  380:       startpos = OVERLAY_POSITION (start);
  381:       if (startpos <= pos)
  382:         {
  383:           if (idx < len)
  384:             vec[idx] = overlay;
  385:           /* Keep counting overlays even if we can't return them all.  */
  386:           idx++;
  387:         }
  388:     }
  389: 
  390:   for (tail = current_buffer->overlays_after; tail; tail = tail->next)
  391:     {
  392:       XSETMISC (overlay, tail);
  393: 
  394:       start = OVERLAY_START (overlay);
  395:       startpos = OVERLAY_POSITION (start);
  396:       if (pos < startpos)
  397:         break;
  398:       end = OVERLAY_END (overlay);
  399:       endpos = OVERLAY_POSITION (end);
  400:       if (pos <= endpos)
  401:         {
  402:           if (idx < len)
  403:             vec[idx] = overlay;
  404:           idx++;
  405:         }
  406:     }
  407: 
  408:   return idx;
  409: }
  410: 
  411: /* Return the value of property PROP, in OBJECT at POSITION.
  412:    It's the value of PROP that a char inserted at POSITION would get.
  413:    OBJECT is optional and defaults to the current buffer.
  414:    If OBJECT is a buffer, then overlay properties are considered as well as
  415:    text properties.
  416:    If OBJECT is a window, then that window's buffer is used, but
  417:    window-specific overlays are considered only if they are associated
  418:    with OBJECT. */
  419: Lisp_Object
  420: get_pos_property (position, prop, object)
  421:      Lisp_Object position, object;
  422:      register Lisp_Object prop;
  423: {
  424:   CHECK_NUMBER_COERCE_MARKER (position);
  425: 
  426:   if (NILP (object))
  427:     XSETBUFFER (object, current_buffer);
  428:   else if (WINDOWP (object))
  429:     object = XWINDOW (object)->buffer;
  430: 
  431:   if (!BUFFERP (object))
  432:     /* pos-property only makes sense in buffers right now, since strings
  433:        have no overlays and no notion of insertion for which stickiness
  434:        could be obeyed.  */
  435:     return Fget_text_property (position, prop, object);
  436:   else
  437:     {
  438:       int posn = XINT (position);
  439:       int noverlays;
  440:       Lisp_Object *overlay_vec, tem;
  441:       struct buffer *obuf = current_buffer;
  442: 
  443:       set_buffer_temp (XBUFFER (object));
  444: 
  445:       /* First try with room for 40 overlays.  */
  446:       noverlays = 40;
  447:       overlay_vec = (Lisp_Object *) alloca (noverlays * sizeof (Lisp_Object));
  448:       noverlays = overlays_around (posn, overlay_vec, noverlays);
  449: 
  450:       /* If there are more than 40,
  451:          make enough space for all, and try again.  */
  452:       if (noverlays > 40)
  453:         {
  454:           overlay_vec = (Lisp_Object *) alloca (noverlays * sizeof (Lisp_Object));
  455:           noverlays = overlays_around (posn, overlay_vec, noverlays);
  456:         }
  457:       noverlays = sort_overlays (overlay_vec, noverlays, NULL);
  458: 
  459:       set_buffer_temp (obuf);
  460: 
  461:       /* Now check the overlays in order of decreasing priority.  */
  462:       while (--noverlays >= 0)
  463:         {
  464:           Lisp_Object ol = overlay_vec[noverlays];
  465:           tem = Foverlay_get (ol, prop);
  466:           if (!NILP (tem))
  467:             {
  468:               /* Check the overlay is indeed active at point.  */
  469:               Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
  470:               if ((OVERLAY_POSITION (start) == posn
  471:                    && XMARKER (start)->insertion_type == 1)
  472:                   || (OVERLAY_POSITION (finish) == posn
  473:                       && XMARKER (finish)->insertion_type == 0))
  474:                 ; /* The overlay will not cover a char inserted at point.  */
  475:               else
  476:                 {
  477:                   return tem;
  478:                 }
  479:             }
  480:         }
  481: 
  482:       { /* Now check the text-properties.  */
  483:         int stickiness = text_property_stickiness (prop, position, object);
  484:         if (stickiness > 0)
  485:           return Fget_text_property (position, prop, object);
  486:         else if (stickiness < 0
  487:                  && XINT (position) > BUF_BEGV (XBUFFER (object)))
  488:           return Fget_text_property (make_number (XINT (position) - 1),
  489:                                      prop, object);
  490:         else
  491:           return Qnil;
  492:       }
  493:     }
  494: }
  495: 
  496: /* Find the field surrounding POS in *BEG and *END.  If POS is nil,
  497:    the value of point is used instead.  If BEG or END is null,
  498:    means don't store the beginning or end of the field.
  499: 
  500:    BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
  501:    results; they do not effect boundary behavior.
  502: 
  503:    If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
  504:    position of a field, then the beginning of the previous field is
  505:    returned instead of the beginning of POS's field (since the end of a
  506:    field is actually also the beginning of the next input field, this
  507:    behavior is sometimes useful).  Additionally in the MERGE_AT_BOUNDARY
  508:    true case, if two fields are separated by a field with the special
  509:    value `boundary', and POS lies within it, then the two separated
  510:    fields are considered to be adjacent, and POS between them, when
  511:    finding the beginning and ending of the "merged" field.
  512: 
  513:    Either BEG or END may be 0, in which case the corresponding value
  514:    is not stored.  */
  515: 
  516: static void
  517: find_field (pos, merge_at_boundary, beg_limit, beg, end_limit, end)
  518:      Lisp_Object pos;
  519:      Lisp_Object merge_at_boundary;
  520:      Lisp_Object beg_limit, end_limit;
  521:      int *beg, *end;
  522: {
  523:   /* Fields right before and after the point.  */
  524:   Lisp_Object before_field, after_field;
  525:   /* 1 if POS counts as the start of a field.  */
  526:   int at_field_start = 0;
  527:   /* 1 if POS counts as the end of a field.  */
  528:   int at_field_end = 0;
  529: 
  530:   if (NILP (pos))
  531:     XSETFASTINT (pos, PT);
  532:   else
  533:     CHECK_NUMBER_COERCE_MARKER (pos);
  534: 
  535:   after_field
  536:     = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
  537:   before_field
  538:     = (XFASTINT (pos) > BEGV
  539:        ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
  540:                                         Qfield, Qnil, NULL)
  541:        /* Using nil here would be a more obvious choice, but it would
  542:           fail when the buffer starts with a non-sticky field.  */
  543:        : after_field);
  544: 
  545:   /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
  546:      and POS is at beginning of a field, which can also be interpreted
  547:      as the end of the previous field.  Note that the case where if
  548:      MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
  549:      more natural one; then we avoid treating the beginning of a field
  550:      specially.  */
  551:   if (NILP (merge_at_boundary))
  552:     {
  553:       Lisp_Object field = get_pos_property (pos, Qfield, Qnil);
  554:       if (!EQ (field, after_field))
  555:         at_field_end = 1;
  556:       if (!EQ (field, before_field))
  557:         at_field_start = 1;
  558:       if (NILP (field) && at_field_start && at_field_end)
  559:         /* If an inserted char would have a nil field while the surrounding
  560:            text is non-nil, we're probably not looking at a
  561:            zero-length field, but instead at a non-nil field that's
  562:            not intended for editing (such as comint's prompts).  */
  563:         at_field_end = at_field_start = 0;
  564:     }
  565: 
  566:   /* Note about special `boundary' fields:
  567: 
  568:      Consider the case where the point (`.') is between the fields `x' and `y':
  569: 
  570:         xxxx.yyyy
  571: 
  572:      In this situation, if merge_at_boundary is true, we consider the
  573:      `x' and `y' fields as forming one big merged field, and so the end
  574:      of the field is the end of `y'.
  575: 
  576:      However, if `x' and `y' are separated by a special `boundary' field
  577:      (a field with a `field' char-property of 'boundary), then we ignore
  578:      this special field when merging adjacent fields.  Here's the same
  579:      situation, but with a `boundary' field between the `x' and `y' fields:
  580: 
  581:         xxx.BBBByyyy
  582: 
  583:      Here, if point is at the end of `x', the beginning of `y', or
  584:      anywhere in-between (within the `boundary' field), we merge all
  585:      three fields and consider the beginning as being the beginning of
  586:      the `x' field, and the end as being the end of the `y' field.  */
  587: 
  588:   if (beg)