OpenSSL build fixes from Nelson

[sxemacs] / src / editfns.c

/* Lisp functions pertaining to editing.
   Copyright (C) 1985-1987, 1989, 1992-1995 Free Software Foundation, Inc.
   Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
   Copyright (C) 1996 Ben Wing.

This file is part of SXEmacs

SXEmacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

SXEmacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. */


/* Synched up with: Mule 2.0, FSF 19.30. */

/* This file has been Mule-ized. */

/* Hacked on for Mule by Ben Wing, December 1994. */

#include <config.h>
#include "lisp.h"

#include "buffer.h"
#include "commands.h"
#define INCLUDE_EVENTS_H_PRIVATE_SPHERE
#include "events/events.h"              /* for EVENTP */
#include "extents.h"
#include "ui/frame.h"
#include "ui/insdel.h"
#include "ui/window.h"
#include "casetab.h"
#include "chartab.h"
#include "line-number.h"

#include "systime.h"
#include "sysdep.h"
#include "syspwd.h"
#include "sysfile.h"            /* for getcwd */

/* Some static data, and a function to initialize it for each run */

Lisp_Object Vsystem_name;       /* #### - I don't see why this should be */
                                /* static, either...  --Stig */
#if 0                           /* XEmacs - this is now dynamic */
                                /* if at some point it's deemed desirable to
                                   use lisp variables here, then they can be
                                   initialized to nil and then set to their
                                   real values upon the first call to the
                                   functions that generate them. --stig */
Lisp_Object Vuser_real_login_name;      /* login name of current user ID */
Lisp_Object Vuser_login_name;   /* user name from LOGNAME or USER.  */
#endif

/* It's useful to be able to set this as user customization, so we'll
   keep it. */
Lisp_Object Vuser_full_name;
EXFUN(Fuser_full_name, 1);

Lisp_Object Qformat;

Lisp_Object Qpoint, Qmark, Qregion_beginning, Qregion_end;

Lisp_Object Quser_files_and_directories;

/* This holds the value of `environ' produced by the previous
   call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
   has never been called.  */
static char **environbuf;

void init_editfns(void)
{
/* Only used in removed code below. */
        char *p;

        environbuf = 0;

        /* Set up system_name even when dumping.  */
        init_system_name();

#ifndef CANNOT_DUMP
        if (!initialized)
                return;
#endif

        if ((p = getenv("NAME")))
                /* I don't think it's the right thing to do the ampersand
                   modification on NAME.  Not that it matters anymore...  -hniksic */
                Vuser_full_name = build_ext_string(p, Qnative);
        else
                Vuser_full_name = Fuser_full_name(Qnil);
}
\f
DEFUN("char-to-string", Fchar_to_string, 1, 1, 0,       /*
Convert CHARACTER to a one-character string containing that character.
*/
      (character))
{
        Bytecount len;
        Bufbyte str[MAX_EMCHAR_LEN];

        if (EVENTP(character)) {
                Lisp_Object ch2 =
                    Fevent_to_character(character, Qt, Qnil, Qnil);
                if (NILP(ch2))
                        return
                            signal_simple_continuable_error
                            ("character has no ASCII equivalent:",
                             Fcopy_event(character, Qnil));
                character = ch2;
        }

        CHECK_CHAR_COERCE_INT(character);

        len = set_charptr_emchar(str, XCHAR(character));
        return make_string(str, len);
}

DEFUN("string-to-char", Fstring_to_char, 1, 1, 0,       /*
Convert arg STRING to a character, the first character of that string.
An empty string will return the constant `nil'.
*/
      (string))
{
        Lisp_String *p;
        CHECK_STRING(string);

        p = XSTRING(string);
        if (string_length(p) != 0)
                return make_char(string_char(p, 0));
        else
                /* This used to return Qzero.  That is broken, broken, broken. */
                /* It might be kinder to signal an error directly. -slb */
                return Qnil;
}
\f
static Lisp_Object buildmark(Bufpos val, Lisp_Object buffer)
{
        Lisp_Object mark = Fmake_marker();
        Fset_marker(mark, make_int(val), buffer);
        return mark;
}

DEFUN("point", Fpoint, 0, 1, 0, /*
Return value of point, as an integer.
Beginning of buffer is position (point-min).
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return make_int(BUF_PT(b));
}

DEFUN("point-marker", Fpoint_marker, 0, 2, 0,   /*
Return value of point, as a marker object.
This marker is a copy; you may modify it with reckless abandon.
If optional argument DONT-COPY-P is non-nil, then it returns the real
point-marker; modifying the position of this marker will move point.
It is illegal to change the buffer of it, or make it point nowhere.
If BUFFER is nil, the current buffer is assumed.
*/
      (dont_copy_p, buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        if (NILP(dont_copy_p))
                return Fcopy_marker(b->point_marker, Qnil);
        else
                return b->point_marker;
}

/* The following two functions end up being identical but it's
   cleaner to declare them separately. */

Bufpos bufpos_clip_to_bounds(Bufpos lower, Bufpos num, Bufpos upper)
{
        return (num < lower ? lower : num > upper ? upper : num);
}

Bytind bytind_clip_to_bounds(Bytind lower, Bytind num, Bytind upper)
{
        return (num < lower ? lower : num > upper ? upper : num);
}

/*
 * Chuck says:
 * There is no absolute way to determine if goto-char is the function
 * being run.  this-command doesn't work because it is often eval'd
 * and this-command ends up set to eval-expression.  So this flag gets
 * added for now.
 *
 * Jamie thinks he's wrong, but we'll leave this in for now.
 */
int atomic_extent_goto_char_p;

DEFUN("goto-char", Fgoto_char, 1, 2, "NGoto char: ",    /*
Set point to POSITION, a number or marker.
Beginning of buffer is position (point-min), end is (point-max).
If BUFFER is nil, the current buffer is assumed.
Return value of POSITION, as an integer.
*/
      (position, buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        Bufpos n = get_buffer_pos_char(b, position, GB_COERCE_RANGE);
        BUF_SET_PT(b, n);
        atomic_extent_goto_char_p = 1;
        return make_int(n);
}

static Lisp_Object region_limit(int beginningp, struct buffer *b)
{
        Lisp_Object m;

#if 0                           /* FSFmacs */
        if (!NILP(Vtransient_mark_mode) && NILP(Vmark_even_if_inactive)
            && NILP(b->mark_active))
                Fsignal(Qmark_inactive, Qnil);
#endif
        m = Fmarker_position(b->mark);
        if (NILP(m))
                error("There is no region now");
        if (!!(BUF_PT(b) < XINT(m)) == !!beginningp)
                return make_int(BUF_PT(b));
        else
                return m;
}

DEFUN("region-beginning", Fregion_beginning, 0, 1, 0,   /*
Return position of beginning of region in BUFFER, as an integer.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        return region_limit(1, decode_buffer(buffer, 1));
}

DEFUN("region-end", Fregion_end, 0, 1, 0,       /*
Return position of end of region in BUFFER, as an integer.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        return region_limit(0, decode_buffer(buffer, 1));
}

/* Whether to use lispm-style active-regions */
int zmacs_regions;

/* Whether the zmacs region is active.  This is not per-buffer because
   there can be only one active region at a time.  #### Now that the
   zmacs region are not directly tied to the X selections this may not
   necessarily have to be true.  */
int zmacs_region_active_p;

int zmacs_region_stays;

Lisp_Object Qzmacs_update_region, Qzmacs_deactivate_region;
Lisp_Object Qzmacs_region_buffer;

void zmacs_update_region(void)
{
        /* This function can GC */
        if (zmacs_region_active_p)
                call0(Qzmacs_update_region);
}

void zmacs_deactivate_region(void)
{
        /* This function can GC */
        if (zmacs_region_active_p)
                call0(Qzmacs_deactivate_region);
}

Lisp_Object zmacs_region_buffer(void)
{
        if (zmacs_region_active_p)
                return call0(Qzmacs_region_buffer);
        else
                return Qnil;
}

DEFUN("mark-marker", Fmark_marker, 0, 2, 0,     /*
Return this buffer's mark, as a marker object.
If `zmacs-regions' is true, then this returns nil unless the region is
currently in the active (highlighted) state.  If optional argument FORCE
is t, this returns the mark (if there is one) regardless of the zmacs-region
state.  You should *generally* not use the mark unless the region is active,
if the user has expressed a preference for the zmacs-region model.
Watch out!  Moving this marker changes the mark position.
If you set the marker not to point anywhere, the buffer will have no mark.
If BUFFER is nil, the current buffer is assumed.
*/
      (force, buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        if (!zmacs_regions || zmacs_region_active_p || !NILP(force))
                return b->mark;
        return Qnil;
}
\f
/* The saved object is a cons:

   (COPY-OF-POINT-MARKER . COPY-OF-MARK)

   We used to have another cons for a VISIBLE-P element, which was t
   if `(eq (current-buffer) (window-buffer (selected-window)))' but it
   was unused for a long time, so I removed it.  --hniksic */
Lisp_Object save_excursion_save(void)
{
        struct buffer *b;

        /* #### Huh?  --hniksic */
        /*if (preparing_for_armageddon) return Qnil; */

#ifdef ERROR_CHECK_BUFPOS
        assert(XINT(Fpoint(Qnil)) ==
               XINT(Fmarker_position(Fpoint_marker(Qt, Qnil))));
#endif

        b = current_buffer;

        return noseeum_cons(noseeum_copy_marker(b->point_marker, Qnil),
                            noseeum_copy_marker(b->mark, Qnil));
}

Lisp_Object save_excursion_restore(Lisp_Object info)
{
        Lisp_Object buffer = Fmarker_buffer(XCAR(info));

        /* If buffer being returned to is now deleted, avoid error --
           otherwise could get error here while unwinding to top level and
           crash.  In that case, Fmarker_buffer returns nil now.  */
        if (!NILP(buffer)) {
                struct buffer *buf = XBUFFER(buffer);
                struct gcpro gcpro1;
                GCPRO1(info);
                set_buffer_internal(buf);
                Fgoto_char(XCAR(info), buffer);
                Fset_marker(buf->mark, XCDR(info), buffer);

#if 0                           /* We used to make the current buffer visible in the selected window
                                   if that was true previously.  That avoids some anomalies.
                                   But it creates others, and it wasn't documented, and it is simpler
                                   and cleaner never to alter the window/buffer connections.  */
                /* I'm certain some code somewhere depends on this behavior. --jwz */
                /* Even if it did, it certainly doesn't matter anymore, because
                   this has been the behavior for countless XEmacs releases
                   now.  --hniksic */
                if (visible
                    && (current_buffer !=
                        XBUFFER(XWINDOW(selected_window)->buffer)))
                        switch_to_buffer(Fcurrent_buffer(), Qnil);
#endif

                UNGCPRO;
        }

        /* Free all the junk we allocated, so that a `save-excursion' comes
           for free in terms of GC junk. */
        free_marker(XMARKER(XCAR(info)));
        free_marker(XMARKER(XCDR(info)));
        free_cons(XCONS(info));
        return Qnil;
}

DEFUN("save-excursion", Fsave_excursion, 0, UNEVALLED, 0,       /*
Save point, mark, and current buffer; execute BODY; restore those things.
Executes BODY just like `progn'.
The values of point, mark and the current buffer are restored
even in case of abnormal exit (throw or error).
*/
      (args))
{
        /* This function can GC */
        int speccount = specpdl_depth();

        record_unwind_protect(save_excursion_restore, save_excursion_save());

        return unbind_to(speccount, Fprogn(args));
}

Lisp_Object save_current_buffer_restore(Lisp_Object buffer)
{
        struct buffer *buf = XBUFFER(buffer);
        /* Avoid signaling an error if the buffer is no longer alive.  This
           is for consistency with save-excursion.  */
        if (BUFFER_LIVE_P(buf))
                set_buffer_internal(buf);
        return Qnil;
}

DEFUN("save-current-buffer", Fsave_current_buffer, 0, UNEVALLED, 0,     /*
Save the current buffer; execute BODY; restore the current buffer.
Executes BODY just like `progn'.
*/
      (args))
{
        /* This function can GC */
        int speccount = specpdl_depth();

        record_unwind_protect(save_current_buffer_restore, Fcurrent_buffer());

        return unbind_to(speccount, Fprogn(args));
}
\f
DEFUN("buffer-size", Fbuffer_size, 0, 1, 0,     /*
Return the number of characters in BUFFER.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return make_int(BUF_SIZE(b));
}

DEFUN("point-min", Fpoint_min, 0, 1, 0, /*
Return the minimum permissible value of point in BUFFER.
This is 1, unless narrowing (a buffer restriction)
is in effect, in which case it may be greater.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return make_int(BUF_BEGV(b));
}

DEFUN("point-min-marker", Fpoint_min_marker, 0, 1, 0,   /*
Return a marker to the minimum permissible value of point in BUFFER.
This is the beginning, unless narrowing (a buffer restriction)
is in effect, in which case it may be greater.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return buildmark(BUF_BEGV(b), make_buffer(b));
}

DEFUN("point-max", Fpoint_max, 0, 1, 0, /*
Return the maximum permissible value of point in BUFFER.
This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
is in effect, in which case it may be less.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return make_int(BUF_ZV(b));
}

DEFUN("point-max-marker", Fpoint_max_marker, 0, 1, 0,   /*
Return a marker to the maximum permissible value of point in BUFFER.
This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
is in effect, in which case it may be less.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return buildmark(BUF_ZV(b), make_buffer(b));
}

DEFUN("following-char", Ffollowing_char, 0, 1, 0,       /*
Return the character following point.
At the end of the buffer or accessible region, return 0.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        if (BUF_PT(b) >= BUF_ZV(b))
                return Qzero;   /* #### Gag me! */
        else
                return make_char(BUF_FETCH_CHAR(b, BUF_PT(b)));
}

DEFUN("preceding-char", Fpreceding_char, 0, 1, 0,       /*
Return the character preceding point.
At the beginning of the buffer or accessible region, return 0.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        if (BUF_PT(b) <= BUF_BEGV(b))
                return Qzero;   /* #### Gag me! */
        else
                return make_char(BUF_FETCH_CHAR(b, BUF_PT(b) - 1));
}

DEFUN("bobp", Fbobp, 0, 1, 0,   /*
Return t if point is at the beginning of the buffer.
If the buffer is narrowed, this means the beginning of the narrowed part.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return BUF_PT(b) == BUF_BEGV(b) ? Qt : Qnil;
}

DEFUN("eobp", Feobp, 0, 1, 0,   /*
Return t if point is at the end of the buffer.
If the buffer is narrowed, this means the end of the narrowed part.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return BUF_PT(b) == BUF_ZV(b) ? Qt : Qnil;
}

int beginning_of_line_p(struct buffer *b, Bufpos pt)
{
        return pt <= BUF_BEGV(b) || BUF_FETCH_CHAR(b, pt - 1) == '\n';
}

DEFUN("bolp", Fbolp, 0, 1, 0,   /*
Return t if point is at the beginning of a line.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return beginning_of_line_p(b, BUF_PT(b)) ? Qt : Qnil;
}

DEFUN("eolp", Feolp, 0, 1, 0,   /*
Return t if point is at the end of a line.
`End of a line' includes point being at the end of the buffer.
If BUFFER is nil, the current buffer is assumed.
*/
      (buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        return (BUF_PT(b) == BUF_ZV(b) || BUF_FETCH_CHAR(b, BUF_PT(b)) == '\n')
            ? Qt : Qnil;
}

DEFUN("char-after", Fchar_after, 0, 2, 0,       /*
Return the character at position POS in BUFFER.
POS is an integer or a marker.
If POS is out of range, the value is nil.
if POS is nil, the value of point is assumed.
If BUFFER is nil, the current buffer is assumed.
*/
      (pos, buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        Bufpos n = (NILP(pos) ? BUF_PT(b) :
                    get_buffer_pos_char(b, pos, GB_NO_ERROR_IF_BAD));

        if (n < 0 || n == BUF_ZV(b))
                return Qnil;
        return make_char(BUF_FETCH_CHAR(b, n));
}

DEFUN("char-before", Fchar_before, 0, 2, 0,     /*
Return the character preceding position POS in BUFFER.
POS is an integer or a marker.
If POS is out of range, the value is nil.
if POS is nil, the value of point is assumed.
If BUFFER is nil, the current buffer is assumed.
*/
      (pos, buffer))
{
        struct buffer *b = decode_buffer(buffer, 1);
        Bufpos n = (NILP(pos) ? BUF_PT(b) :
                    get_buffer_pos_char(b, pos, GB_NO_ERROR_IF_BAD));

        n--;

        if (n < BUF_BEGV(b))
                return Qnil;
        return make_char(BUF_FETCH_CHAR(b, n));
}

#include <sys/stat.h>
#include <fcntl.h>
#include <errno.h>
#include <limits.h>

\f
DEFUN("temp-directory", Ftemp_directory, 0, 0, 0,       /*
Return the pathname to the directory to use for temporary files.
On MS Windows, this is obtained from the TEMP or TMP environment variables,
defaulting to / if they are both undefined.
On Unix it is obtained from TMPDIR, with /tmp as the default.
*/
      ())
{
        char *tmpdir;
        tmpdir = getenv("TMPDIR");
        char path[5 /* strlen ("/tmp/") */  + 1 + _POSIX_PATH_MAX];
        if (!tmpdir) {
                struct stat st;
                int myuid = getuid();

                strcpy(path, "/tmp/");
                strncat(path, user_login_name(NULL), _POSIX_PATH_MAX);
                path[sizeof(path)-1]=0;
                if (lstat(path, &st) < 0 && errno == ENOENT) {
                        mkdir(path, 0700);      /* ignore retval -- checked next anyway. */
                }
                if (lstat(path, &st) == 0 && st.st_uid == (uid_t) myuid &&
                    S_ISDIR(st.st_mode)) {
                        tmpdir = path;
                } else {
                        const char* home_env = getenv("HOME");
                        if ( home_env ) {
                                strncpy(path, home_env, sizeof(path)-1);
                                strncat(path, "/tmp/", sizeof(path)-1);
                                if (stat(path, &st) < 0 && errno == ENOENT) {
                                        int fd;
                                        char warnpath[ 
                                                /* strlen(".created_by_sxemacs") */ 
                                                19 + _POSIX_PATH_MAX + 1];
                                        mkdir(path, 0700);      /* ignore retvals */
                                        strncpy(warnpath, path, _POSIX_PATH_MAX);
                                        warnpath[sizeof(warnpath)-1]=0;
                                        
                                        /* we already are reserved these 20 bytes... */
                                        strcat(warnpath, ".created_by_sxemacs");
                                        if ((fd = open(warnpath, O_WRONLY | O_CREAT,
                                                       0644)) > 0) {
                                                write(fd, "SXEmacs created this directory "
                                                          "because /tmp/<yourname> "
                                                          "was unavailable -- \nPlease check !\n",  89);
                                                close(fd);
                                        }
                                }
                        }
                        if (stat(path, &st) == 0 && st.st_uid == (uid_t) myuid 
                            && S_ISDIR(st.st_mode)) {
                                tmpdir = path;
                        } else {
                                tmpdir = "/tmp";
                        }
                }
        }

        return build_ext_string(tmpdir, Qfile_name);
}

DEFUN("user-login-name", Fuser_login_name, 0, 1, 0,     /*
Return the name under which the user logged in, as a string.
This is based on the effective uid, not the real uid.
Also, if the environment variable LOGNAME or USER is set,
that determines the value of this function.
If the optional argument UID is present, then environment variables are
ignored and this function returns the login name for that UID, or nil.
*/
      (uid))
{
        char *returned_name;
        uid_t local_uid;

        if (!NILP(uid)) {
                CHECK_INT(uid);
                local_uid = XINT(uid);
                returned_name = user_login_name(&local_uid);
        } else {
                returned_name = user_login_name(NULL);
        }
        /* #### - I believe this should return nil instead of "unknown" when pw==0
           pw=0 is indicated by a null return from user_login_name
         */
        return returned_name ? build_string(returned_name) : Qnil;
}

/* This function may be called from other C routines when a
   character string representation of the user_login_name is
   needed but a Lisp Object is not.  The UID is passed by
   reference.  If UID == NULL, then the USER name
   for the user running XEmacs will be returned.  This
   corresponds to a nil argument to Fuser_login_name.
*/
char *user_login_name(uid_t * uid)
{
        /* uid == NULL to return name of this user */
        if (uid != NULL) {
                struct passwd *pw = getpwuid(*uid);
                return pw ? pw->pw_name : NULL;
        } else {
                /* #### - when euid != uid, then LOGNAME and USER are leftovers from the
                   old environment (I site observed behavior on sunos and linux), so the
                   environment variables should be disregarded in that case.  --Stig */
                char *user_name = getenv("LOGNAME");
                if (!user_name)
                        user_name = getenv(
                                                  "USER"
                            );
                if (user_name)