Mercurial > hg > xemacs-beta

comparison src/editfns.c @ 771:943eaba38521

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-03-13 08:51:24 by ben] The big ben-mule-21-5 check-in! Various files were added and deleted. See CHANGES-ben-mule. There are still some test suite failures. No crashes, though. Many of the failures have to do with problems in the test suite itself rather than in the actual code. I'll be addressing these in the next day or so -- none of the test suite failures are at all critical. Meanwhile I'll be trying to address the biggest issues -- i.e. build or run failures, which will almost certainly happen on various platforms. All comments should be sent to ben@xemacs.org -- use a Cc: if necessary when sending to mailing lists. There will be pre- and post- tags, something like pre-ben-mule-21-5-merge-in, and post-ben-mule-21-5-merge-in.
author ben
date Wed, 13 Mar 2002 08:54:06 +0000
parents a307f9a2021d
children e38acbeb1cae
comparison
equal deleted inserted replaced
770:336a418893b5 771:943eaba38521
1 /* Lisp functions pertaining to editing. 1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985-1987, 1989, 1992-1995 Free Software Foundation, Inc. 2 Copyright (C) 1985-1987, 1989, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
4 Copyright (C) 1996 Ben Wing. 4 Copyright (C) 1996, 2001, 2002 Ben Wing.
5 5
6 This file is part of XEmacs. 6 This file is part of XEmacs.
7 7
8 XEmacs is free software; you can redistribute it and/or modify it 8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the 9 under the terms of the GNU General Public License as published by the
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */ 21 Boston, MA 02111-1307, USA. */
22 22
23 /* Synched up with: Mule 2.0, FSF 19.30. */ 23 /* Synched up with: Mule 2.0, FSF 19.30. */
24 24
25 /* This file has been Mule-ized. */ 25 /* This file has been Mule-ized, June 2001. */
26 26
27 /* Hacked on for Mule by Ben Wing, December 1994. */ 27 /* Hacked on for Mule by Ben Wing, December 1994. */
28 28
29 #include <config.h> 29 #include <config.h>
30 #include "lisp.h" 30 #include "lisp.h"
41 #include "line-number.h" 41 #include "line-number.h"
42 42
43 #include "systime.h" 43 #include "systime.h"
44 #include "sysdep.h" 44 #include "sysdep.h"
45 #include "syspwd.h" 45 #include "syspwd.h"
46 #include "sysfile.h" /* for getcwd */ 46 #include "sysproc.h" /* for qxe_getpid() */
47 #include "sysfile.h"
48 #include "sysdir.h"
47 49
48 /* Some static data, and a function to initialize it for each run */ 50 /* Some static data, and a function to initialize it for each run */
49 51
50 Lisp_Object Vsystem_name; /* #### - I don't see why this should be */ 52 Lisp_Object Vsystem_name; /* #### - I don't see why this should be */
51 /* static, either... --Stig */ 53 /* static, either... --Stig */
71 Lisp_Object Quser_files_and_directories; 73 Lisp_Object Quser_files_and_directories;
72 74
73 /* This holds the value of `environ' produced by the previous 75 /* This holds the value of `environ' produced by the previous
74 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule 76 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
75 has never been called. */ 77 has never been called. */
76 static char **environbuf; 78 static Extbyte **environbuf;
77 79
78 void 80 void
79 init_editfns (void) 81 init_editfns (void)
80 { 82 {
81 /* Only used in removed code below. */ 83 /* Only used in removed code below. */
82 char *p; 84 Intbyte *p;
83 85
84 environbuf = 0; 86 environbuf = 0;
85 87
86 /* Set up system_name even when dumping. */ 88 /* Set up system_name even when dumping. */
87 init_system_name (); 89 init_system_name ();
89 #ifndef CANNOT_DUMP 91 #ifndef CANNOT_DUMP
90 if (!initialized) 92 if (!initialized)
91 return; 93 return;
92 #endif 94 #endif
93 95
94 if ((p = getenv ("NAME"))) 96 if ((p = egetenv ("NAME")))
95 /* I don't think it's the right thing to do the ampersand 97 /* I don't think it's the right thing to do the ampersand
96 modification on NAME. Not that it matters anymore... -hniksic */ 98 modification on NAME. Not that it matters anymore... -hniksic */
97 Vuser_full_name = build_ext_string (p, Qnative); 99 Vuser_full_name = build_intstring (p);
98 else 100 else
99 Vuser_full_name = Fuser_full_name (Qnil); 101 Vuser_full_name = Fuser_full_name (Qnil);
100 } 102 }
101 103
102 DEFUN ("char-to-string", Fchar_to_string, 1, 1, 0, /* 104 DEFUN ("char-to-string", Fchar_to_string, 1, 1, 0, /*
395 /* This function can GC */ 397 /* This function can GC */
396 int speccount = specpdl_depth (); 398 int speccount = specpdl_depth ();
397 399
398 record_unwind_protect (save_excursion_restore, save_excursion_save ()); 400 record_unwind_protect (save_excursion_restore, save_excursion_save ());
399 401
400 return unbind_to (speccount, Fprogn (args)); 402 return unbind_to_1 (speccount, Fprogn (args));
401 } 403 }
402 404
403 Lisp_Object 405 Lisp_Object
404 save_current_buffer_restore (Lisp_Object buffer) 406 save_current_buffer_restore (Lisp_Object buffer)
405 { 407 {
420 /* This function can GC */ 422 /* This function can GC */
421 int speccount = specpdl_depth (); 423 int speccount = specpdl_depth ();
422 424
423 record_unwind_protect (save_current_buffer_restore, Fcurrent_buffer ()); 425 record_unwind_protect (save_current_buffer_restore, Fcurrent_buffer ());
424 426
425 return unbind_to (speccount, Fprogn (args)); 427 return unbind_to_1 (speccount, Fprogn (args));
426 } 428 }
427 429
428 DEFUN ("buffer-size", Fbuffer_size, 0, 1, 0, /* 430 DEFUN ("buffer-size", Fbuffer_size, 0, 1, 0, /*
429 Return the number of characters in BUFFER. 431 Return the number of characters in BUFFER.
430 If BUFFER is nil, the current buffer is assumed. 432 If BUFFER is nil, the current buffer is assumed.
454 If BUFFER is nil, the current buffer is assumed. 456 If BUFFER is nil, the current buffer is assumed.
455 */ 457 */
456 (buffer)) 458 (buffer))
457 { 459 {
458 struct buffer *b = decode_buffer (buffer, 1); 460 struct buffer *b = decode_buffer (buffer, 1);
459 return buildmark (BUF_BEGV (b), make_buffer (b)); 461 return buildmark (BUF_BEGV (b), wrap_buffer (b));
460 } 462 }
461 463
462 DEFUN ("point-max", Fpoint_max, 0, 1, 0, /* 464 DEFUN ("point-max", Fpoint_max, 0, 1, 0, /*
463 Return the maximum permissible value of point in BUFFER. 465 Return the maximum permissible value of point in BUFFER.
464 This is (1+ (buffer-size)), unless narrowing (a buffer restriction) 466 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
478 If BUFFER is nil, the current buffer is assumed. 480 If BUFFER is nil, the current buffer is assumed.
479 */ 481 */
480 (buffer)) 482 (buffer))
481 { 483 {
482 struct buffer *b = decode_buffer (buffer, 1); 484 struct buffer *b = decode_buffer (buffer, 1);
483 return buildmark (BUF_ZV (b), make_buffer (b)); 485 return buildmark (BUF_ZV (b), wrap_buffer (b));
484 } 486 }
485 487
486 DEFUN ("following-char", Ffollowing_char, 0, 1, 0, /* 488 DEFUN ("following-char", Ffollowing_char, 0, 1, 0, /*
487 Return the character following point. 489 Return the character following point.
488 At the end of the buffer or accessible region, return 0. 490 At the end of the buffer or accessible region, return 0.
598 if (n < BUF_BEGV (b)) 600 if (n < BUF_BEGV (b))
599 return Qnil; 601 return Qnil;
600 return make_char (BUF_FETCH_CHAR (b, n)); 602 return make_char (BUF_FETCH_CHAR (b, n));
601 } 603 }
602 604
603 #if !defined(WINDOWSNT) && !defined(MSDOS)
604 #include <sys/stat.h>
605 #include <fcntl.h>
606 #include <errno.h>
607 #include <limits.h>
608 #endif
609 605
610 DEFUN ("temp-directory", Ftemp_directory, 0, 0, 0, /* 606 DEFUN ("temp-directory", Ftemp_directory, 0, 0, 0, /*
611 Return the pathname to the directory to use for temporary files. 607 Return the pathname to the directory to use for temporary files.
612 On MS Windows, this is obtained from the TEMP or TMP environment variables, 608 On MS Windows, this is obtained from the TEMP or TMP environment variables,
613 defaulting to / if they are both undefined. 609 defaulting to c:\\ if they are both undefined.
614 On Unix it is obtained from TMPDIR, with /tmp as the default. 610 On Unix it is obtained from TMPDIR, with /tmp as the default.
615 */ 611 */
616 ()) 612 ())
617 { 613 {
618 char *tmpdir; 614 Intbyte *tmpdir;
619 #if defined(WIN32_NATIVE) 615 #if defined(WIN32_NATIVE)
620 tmpdir = getenv ("TEMP"); 616 tmpdir = egetenv ("TEMP");
621 if (!tmpdir) 617 if (!tmpdir)
622 tmpdir = getenv ("TMP"); 618 tmpdir = egetenv ("TMP");
623 if (!tmpdir) 619 if (!tmpdir)
624 tmpdir = "/"; 620 tmpdir = (Intbyte *) "c:\\";
625 #else /* WIN32_NATIVE */ 621 #else /* WIN32_NATIVE */
626 tmpdir = getenv ("TMPDIR"); 622 tmpdir = egetenv ("TMPDIR");
627 if (!tmpdir) 623 if (!tmpdir)
628 { 624 {
629 struct stat st; 625 struct stat st;
630 int myuid = getuid(); 626 int myuid = getuid ();
631 static char path[5 /* strlen ("/tmp/") */ + 1 + _POSIX_PATH_MAX]; 627 Intbyte *login_name = user_login_name (NULL);
632 628 DECLARE_EISTRING (eipath);
633 strcpy (path, "/tmp/"); 629 Intbyte *path;
634 strncat (path, user_login_name (NULL), _POSIX_PATH_MAX); 630
635 if (lstat(path, &st) < 0 && errno == ENOENT) 631 eicpy_c (eipath, "/tmp/");
636 { 632 eicat_rawz (eipath, login_name);
637 mkdir(path, 0700); /* ignore retval -- checked next anyway. */ 633 path = eidata (eipath);
638 } 634 if (qxe_lstat (path, &st) < 0 && errno == ENOENT)
639 if (lstat(path, &st) == 0 && st.st_uid == (uid_t) myuid && 635 qxe_mkdir (path, 0700); /* ignore retval -- checked next anyway. */
640 S_ISDIR(st.st_mode)) 636 if (qxe_lstat (path, &st) == 0 && (int) st.st_uid == myuid
641 { 637 && S_ISDIR (st.st_mode))
642 tmpdir = path; 638 tmpdir = path;
643 }
644 else 639 else
645 { 640 {
646 strcpy(path, getenv("HOME")); strncat(path, "/tmp/", _POSIX_PATH_MAX); 641 eicpy_rawz (eipath, egetenv ("HOME"));
647 if (stat(path, &st) < 0 && errno == ENOENT) 642 eicat_c (eipath, "/tmp/");
643 path = eidata (eipath);
644 if (qxe_stat (path, &st) < 0 && errno == ENOENT)
648 { 645 {
649 int fd; 646 int fd;
650 char warnpath[1+_POSIX_PATH_MAX]; 647 DECLARE_EISTRING (eiwarnpath);
651 mkdir(path, 0700); /* ignore retvals */ 648
652 strcpy(warnpath, path); 649 qxe_mkdir (path, 0700); /* ignore retvals */
653 strncat(warnpath, ".created_by_xemacs", _POSIX_PATH_MAX); 650 eicpy_ei (eiwarnpath, eipath);
654 if ((fd = open(warnpath, O_WRONLY|O_CREAT, 0644)) > 0) 651 eicat_c (eiwarnpath, ".created_by_xemacs");
652 if ((fd = qxe_open (eidata (eiwarnpath),
653 O_WRONLY | O_CREAT, 0644)) > 0)
655 { 654 {
656 write(fd, "XEmacs created this directory because /tmp/<yourname> was unavailable -- \nPlease check !\n", 89); 655 retry_write (fd, "XEmacs created this directory because "
657 close(fd); 656 "/tmp/<yourname> was unavailable -- \n"
657 "Please check !\n", 89);
658 retry_close (fd);
658 } 659 }
659 } 660 }
660 if (stat(path, &st) == 0 && S_ISDIR(st.st_mode)) 661 if (qxe_stat (path, &st) == 0 && S_ISDIR (st.st_mode))
661 { 662 tmpdir = path;
662 tmpdir = path;
663 }
664 else 663 else
665 { 664 tmpdir = (Intbyte *) "/tmp";
666 tmpdir = "/tmp";
667 }
668 } 665 }
669 } 666 }
670 #endif 667 #endif
671 668
672 return build_ext_string (tmpdir, Qfile_name); 669 return build_intstring (tmpdir);
673 } 670 }
674 671
675 DEFUN ("user-login-name", Fuser_login_name, 0, 1, 0, /* 672 DEFUN ("user-login-name", Fuser_login_name, 0, 1, 0, /*
676 Return the name under which the user logged in, as a string. 673 Return the name under which the user logged in, as a string.
677 This is based on the effective uid, not the real uid. 674 This is based on the effective uid, not the real uid.
680 If the optional argument UID is present, then environment variables are 677 If the optional argument UID is present, then environment variables are
681 ignored and this function returns the login name for that UID, or nil. 678 ignored and this function returns the login name for that UID, or nil.
682 */ 679 */
683 (uid)) 680 (uid))
684 { 681 {
685 char *returned_name; 682 Intbyte *returned_name;
686 uid_t local_uid; 683 uid_t local_uid;
687 684
688 if (!NILP (uid)) 685 if (!NILP (uid))
689 { 686 {
690 CHECK_INT (uid); 687 CHECK_INT (uid);
696 returned_name = user_login_name (NULL); 693 returned_name = user_login_name (NULL);
697 } 694 }
698 /* #### - I believe this should return nil instead of "unknown" when pw==0 695 /* #### - I believe this should return nil instead of "unknown" when pw==0
699 pw=0 is indicated by a null return from user_login_name 696 pw=0 is indicated by a null return from user_login_name
700 */ 697 */
701 return returned_name ? build_string (returned_name) : Qnil; 698 return returned_name ? build_intstring (returned_name) : Qnil;
702 } 699 }
703 700
704 /* This function may be called from other C routines when a 701 /* This function may be called from other C routines when a
705 character string representation of the user_login_name is 702 character string representation of the user_login_name is
706 needed but a Lisp Object is not. The UID is passed by 703 needed but a Lisp Object is not. The UID is passed by
707 reference. If UID == NULL, then the USER name 704 reference. If UID == NULL, then the USER name
708 for the user running XEmacs will be returned. This 705 for the user running XEmacs will be returned. This
709 corresponds to a nil argument to Fuser_login_name. 706 corresponds to a nil argument to Fuser_login_name.
710 */ 707
711 char* 708 WARNING: The string returned comes from the data of a Lisp_String and
709 therefore will become garbage after the next GC.
710 */
711 Intbyte *
712 user_login_name (uid_t *uid) 712 user_login_name (uid_t *uid)
713 { 713 {
714 /* uid == NULL to return name of this user */ 714 /* uid == NULL to return name of this user */
715 if (uid != NULL) 715 if (uid != NULL)
716 { 716 {
717 struct passwd *pw = getpwuid (*uid); 717 struct passwd *pw = qxe_getpwuid (*uid);
718 return pw ? pw->pw_name : NULL; 718 return pw ? (Intbyte *) pw->pw_name : NULL;
719 } 719 }
720 else 720 else
721 { 721 {
722 /* #### - when euid != uid, then LOGNAME and USER are leftovers from the 722 /* #### - when euid != uid, then LOGNAME and USER are leftovers from the
723 old environment (I site observed behavior on sunos and linux), so the 723 old environment (I site observed behavior on sunos and linux), so the
724 environment variables should be disregarded in that case. --Stig */ 724 environment variables should be disregarded in that case. --Stig */
725 char *user_name = getenv ("LOGNAME"); 725 Intbyte *user_name = egetenv ("LOGNAME");
726 if (!user_name) 726 if (!user_name)
727 user_name = getenv ( 727 user_name = egetenv (
728 #ifdef WIN32_NATIVE 728 #ifdef WIN32_NATIVE
729 "USERNAME" /* it's USERNAME on NT */ 729 "USERNAME" /* it's USERNAME on NT */
730 #else 730 #else
731 "USER" 731 "USER"
732 #endif 732 #endif
733 ); 733 );
734 if (user_name) 734 if (user_name)
735 return (user_name); 735 return user_name;
736 else 736 else
737 { 737 {
738 struct passwd *pw = getpwuid (geteuid ()); 738 struct passwd *pw = qxe_getpwuid (geteuid ());
739 #ifdef CYGWIN 739 #ifdef CYGWIN
740 /* Since the Cygwin environment may not have an /etc/passwd, 740 /* Since the Cygwin environment may not have an /etc/passwd,
741 return "unknown" instead of the null if the username 741 return "unknown" instead of the null if the username
742 cannot be determined. 742 cannot be determined.
743 */ 743 */
744 /* !!#### fix up in my mule ws */ 744 /* !!#### fix up in my mule ws */
745 return pw ? pw->pw_name : (char *) "unknown"; 745 return (Intbyte *) (pw ? pw->pw_name : "unknown");
746 #else 746 #else
747 /* For all but Cygwin return NULL (nil) */ 747 /* For all but Cygwin return NULL (nil) */
748 return pw ? pw->pw_name : NULL; 748 return pw ? pw->pw_name : NULL;
749 #endif 749 #endif
750 } 750 }
756 This ignores the environment variables LOGNAME and USER, so it differs from 756 This ignores the environment variables LOGNAME and USER, so it differs from
757 `user-login-name' when running under `su'. 757 `user-login-name' when running under `su'.
758 */ 758 */
759 ()) 759 ())
760 { 760 {
761 struct passwd *pw = getpwuid (getuid ()); 761 struct passwd *pw = qxe_getpwuid (getuid ());
762 /* #### - I believe this should return nil instead of "unknown" when pw==0 */ 762 /* #### - I believe this should return nil instead of "unknown" when pw==0 */
763 763
764 Lisp_Object tem = build_string (pw ? pw->pw_name : "unknown");/* no gettext */ 764 Lisp_Object tem = build_string (pw ? pw->pw_name : "unknown");
765 return tem; 765 return tem;
766 } 766 }
767 767
768 DEFUN ("user-uid", Fuser_uid, 0, 0, 0, /* 768 DEFUN ("user-uid", Fuser_uid, 0, 0, 0, /*
769 Return the effective uid of Emacs, as an integer. 769 Return the effective uid of Emacs, as an integer.
792 (user)) 792 (user))
793 { 793 {
794 Lisp_Object user_name; 794 Lisp_Object user_name;
795 struct passwd *pw = NULL; 795 struct passwd *pw = NULL;
796 Lisp_Object tem; 796 Lisp_Object tem;
797 const char *p, *q; 797 const Intbyte *p, *q;
798 798
799 if (NILP (user) && STRINGP (Vuser_full_name)) 799 if (NILP (user) && STRINGP (Vuser_full_name))
800 return Vuser_full_name; 800 return Vuser_full_name;
801 801
802 user_name = (STRINGP (user) ? user : Fuser_login_name (user)); 802 user_name = (STRINGP (user) ? user : Fuser_login_name (user));
803 if (!NILP (user_name)) /* nil when nonexistent UID passed as arg */ 803 if (!NILP (user_name)) /* nil when nonexistent UID passed as arg */
804 { 804 {
805 const char *user_name_ext;
806
807 /* Fuck me. getpwnam() can call select() and (under IRIX at least) 805 /* Fuck me. getpwnam() can call select() and (under IRIX at least)
808 things get wedged if a SIGIO arrives during this time. */ 806 things get wedged if a SIGIO arrives during this time. */
809 TO_EXTERNAL_FORMAT (LISP_STRING, user_name,
810 C_STRING_ALLOCA, user_name_ext,
811 Qnative);
812 slow_down_interrupts (); 807 slow_down_interrupts ();
813 pw = (struct passwd *) getpwnam (user_name_ext); 808 pw = qxe_getpwnam (XSTRING_DATA (user_name));
814 speed_up_interrupts (); 809 speed_up_interrupts ();
815 } 810 }
816 811
817 /* #### - Stig sez: this should return nil instead of "unknown" when pw==0 */ 812 /* #### - Stig sez: this should return nil instead of "unknown" when pw==0 */
818 /* Ben sez: bad idea because it's likely to break something */ 813 /* Ben sez: bad idea because it's likely to break something */
819 #ifndef AMPERSAND_FULL_NAME 814 #ifndef AMPERSAND_FULL_NAME
820 p = pw ? USER_FULL_NAME : "unknown"; /* don't gettext */ 815 p = (Intbyte *) (pw ? USER_FULL_NAME : "unknown"); /* don't gettext */
821 q = strchr (p, ','); 816 q = qxestrchr (p, ',');
822 #else 817 #else
823 p = pw ? USER_FULL_NAME : "unknown"; /* don't gettext */ 818 p = (Intbyte *) (pw ? USER_FULL_NAME : "unknown"); /* don't gettext */
824 q = strchr (p, ','); 819 q = qxestrchr (p, ',');
825 #endif 820 #endif
826 tem = ((!NILP (user) && !pw) 821 tem = ((!NILP (user) && !pw)
827 ? Qnil 822 ? Qnil
828 : make_ext_string ((Extbyte *) p, (q ? q - p : (int) strlen (p)), 823 : make_string (p, (q ? q - p : qxestrlen (p))));
829 Qnative));
830 824
831 #ifdef AMPERSAND_FULL_NAME 825 #ifdef AMPERSAND_FULL_NAME
832 if (!NILP (tem)) 826 if (!NILP (tem))
833 { 827 {
834 p = (char *) XSTRING_DATA (tem); 828 p = XSTRING_DATA (tem);
835 q = strchr (p, '&'); 829 q = qxestrchr (p, '&');
836 /* Substitute the login name for the &, upcasing the first character. */ 830 /* Substitute the login name for the &, upcasing the first character. */
837 if (q) 831 if (q)
838 { 832 {
839 char *r = (char *) alloca (strlen (p) + XSTRING_LENGTH (user_name) + 1); 833 DECLARE_EISTRING (r);
840 memcpy (r, p, q - p); 834 eicpy_raw (r, p, q - p);
841 r[q - p] = 0; 835 eicat_lstr (r, user_name);
842 strcat (r, (char *) XSTRING_DATA (user_name)); 836 eisetch (r, q - p, UPCASE (0, eigetch (r, q - p)));
843 /* #### current_buffer dependency! */ 837 eicat_rawz (r, q + 1);
844 r[q - p] = UPCASE (current_buffer, r[q - p]); 838 tem = eimake_string (r);
845 strcat (r, q + 1);
846 tem = build_string (r);
847 } 839 }
848 } 840 }
849 #endif /* AMPERSAND_FULL_NAME */ 841 #endif /* AMPERSAND_FULL_NAME */
850 842
851 return tem; 843 return tem;
852 } 844 }
853 845
854 static Extbyte *cached_home_directory; 846 static Intbyte *cached_home_directory;
855 847
856 void 848 void
857 uncache_home_directory (void) 849 uncache_home_directory (void)
858 { 850 {
859 cached_home_directory = NULL; /* in some cases, this may cause the leaking 851 if (cached_home_directory)
860 of a few bytes */ 852 xfree (cached_home_directory);
861 } 853 cached_home_directory = NULL;
862 854 }
863 /* !!#### not Mule correct. */ 855
864 856 /* Returns the home directory */
865 /* Returns the home directory, in external format */ 857 Intbyte *
866 Extbyte *
867 get_home_directory (void) 858 get_home_directory (void)
868 { 859 {
869 /* !!#### this is hopelessly bogus. Rule #1: Do not make any assumptions
870 about what format an external string is in. Could be Unicode, for all
871 we know, and then all the operations below are totally bogus.
872 Instead, convert all data to internal format *right* at the juncture
873 between XEmacs and the outside world, the very moment we first get
874 the data. --ben */
875 int output_home_warning = 0; 860 int output_home_warning = 0;
876 861
877 if (cached_home_directory == NULL) 862 if (cached_home_directory == NULL)
878 { 863 {
879 if ((cached_home_directory = (Extbyte *) getenv("HOME")) == NULL) 864 cached_home_directory = egetenv ("HOME");
865 if (cached_home_directory)
866 cached_home_directory = qxestrdup (cached_home_directory);
867 else
880 { 868 {
881 #if defined(WIN32_NATIVE) 869 #if defined (WIN32_NATIVE)
882 char *homedrive, *homepath; 870 Intbyte *homedrive, *homepath;
883 871
884 if ((homedrive = getenv("HOMEDRIVE")) != NULL && 872 if ((homedrive = egetenv ("HOMEDRIVE")) != NULL &&
885 (homepath = getenv("HOMEPATH")) != NULL) 873 (homepath = egetenv ("HOMEPATH")) != NULL)
886 { 874 {
887 cached_home_directory = 875 cached_home_directory =
888 (Extbyte *) xmalloc (strlen (homedrive) + 876 (Intbyte *) xmalloc (qxestrlen (homedrive) +
889 strlen (homepath) + 1); 877 qxestrlen (homepath) + 1);
890 sprintf((char *) cached_home_directory, "%s%s", 878 qxesprintf (cached_home_directory, "%s%s",
891 homedrive, 879 homedrive,
892 homepath); 880 homepath);
893 } 881 }
894 else 882 else
895 { 883 {
896 # if 0 /* changed by ben. This behavior absolutely stinks, and the 884 cached_home_directory = qxestrdup ((Intbyte *) "C:\\");
897 possibility being addressed here occurs quite commonly.
898 Using the current directory makes absolutely no sense. */
899 /*
900 * Use the current directory.
901 * This preserves the existing XEmacs behavior, but is different
902 * from NT Emacs.
903 */
904 if (initial_directory[0] != '\0')
905 {
906 cached_home_directory = (Extbyte*) initial_directory;
907 }
908 else
909 {
910 /* This will probably give the wrong value */
911 cached_home_directory = (Extbyte*) getcwd (NULL, 0);
912 }
913 # else
914 /*
915 * This is NT Emacs behavior
916 */
917 cached_home_directory = (Extbyte *) "C:\\";
918 output_home_warning = 1; 885 output_home_warning = 1;
919 # endif
920 } 886 }
921 #else /* !WIN32_NATIVE */ 887 #else /* !WIN32_NATIVE */
922 /* 888 /*
923 * Unix, typically. 889 * Unix, typically.
924 * Using "/" isn't quite right, but what should we do? 890 * Using "/" isn't quite right, but what should we do?
925 * We probably should try to extract pw_dir from /etc/passwd, 891 * We probably should try to extract pw_dir from /etc/passwd,
926 * before falling back to this. 892 * before falling back to this.
927 */ 893 */
928 cached_home_directory = (Extbyte *) "/"; 894 cached_home_directory = qxestrdup ((Intbyte *) "/");
929 output_home_warning = 1; 895 output_home_warning = 1;
930 #endif /* !WIN32_NATIVE */ 896 #endif /* !WIN32_NATIVE */
931 } 897 }
932 if (initialized && output_home_warning) 898 if (initialized && output_home_warning)
933 { 899 {
946 DEFUN ("user-home-directory", Fuser_home_directory, 0, 0, 0, /* 912 DEFUN ("user-home-directory", Fuser_home_directory, 0, 0, 0, /*
947 Return the user's home directory, as a string. 913 Return the user's home directory, as a string.
948 */ 914 */
949 ()) 915 ())
950 { 916 {
951 Extbyte *path = get_home_directory (); 917 Intbyte *path = get_home_directory ();
952 918
953 return path == NULL ? Qnil : 919 return !path ? Qnil :
954 Fexpand_file_name (Fsubstitute_in_file_name 920 Fexpand_file_name (Fsubstitute_in_file_name (build_intstring (path)),
955 (build_ext_string ((char *) path, Qfile_name)),
956 Qnil); 921 Qnil);
957 } 922 }
958 923
959 DEFUN ("system-name", Fsystem_name, 0, 0, 0, /* 924 DEFUN ("system-name", Fsystem_name, 0, 0, 0, /*
960 Return the name of the machine you are running on, as a string. 925 Return the name of the machine you are running on, as a string.
961 */ 926 */
962 ()) 927 ())
963 { 928 {
964 return Fcopy_sequence (Vsystem_name); 929 return Fcopy_sequence (Vsystem_name);
965 } 930 }
966 931
967 DEFUN ("emacs-pid", Femacs_pid, 0, 0, 0, /* 932 DEFUN ("emacs-pid", Femacs_pid, 0, 0, 0, /*
968 Return the process ID of Emacs, as an integer. 933 Return the process ID of Emacs, as an integer.
969 */ 934 */
970 ()) 935 ())
971 { 936 {
972 return make_int (getpid ()); 937 return make_int (qxe_getpid ());
973 } 938 }
974 939
975 DEFUN ("current-time", Fcurrent_time, 0, 0, 0, /* 940 DEFUN ("current-time", Fcurrent_time, 0, 0, 0, /*
976 Return the current time, as the number of seconds since 1970-01-01 00:00:00. 941 Return the current time, as the number of seconds since 1970-01-01 00:00:00.
977 The time is returned as a list of three integers. The first has the 942 The time is returned as a list of three integers. The first has the
1050 { 1015 {
1051 unsigned int item = (unsigned int) the_time; 1016 unsigned int item = (unsigned int) the_time;
1052 return Fcons (make_int (item >> 16), make_int (item & 0xffff)); 1017 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
1053 } 1018 }
1054 1019
1055 size_t emacs_strftime (char *string, size_t max, const char *format, 1020 size_t emacs_strftime (Extbyte *string, size_t max, const Extbyte *format,
1056 const struct tm *tm); 1021 const struct tm *tm);
1057 static long difftm (const struct tm *a, const struct tm *b); 1022 static long difftm (const struct tm *a, const struct tm *b);
1058 1023
1059 1024
1060 DEFUN ("format-time-string", Fformat_time_string, 1, 2, 0, /* 1025 DEFUN ("format-time-string", Fformat_time_string, 1, 2, 0, /*
1116 /* This is probably enough. */ 1081 /* This is probably enough. */
1117 size = XSTRING_LENGTH (format_string) * 6 + 50; 1082 size = XSTRING_LENGTH (format_string) * 6 + 50;
1118 1083
1119 while (1) 1084 while (1)
1120 { 1085 {
1121 char *buf = (char *) alloca (size); 1086 Extbyte *buf = (Extbyte *) alloca (size);
1087 Extbyte *formext;
1122 *buf = 1; 1088 *buf = 1;
1123 if (emacs_strftime (buf, size, 1089
1124 (const char *) XSTRING_DATA (format_string), 1090 /* !!#### this use of external here is not totally safe, and
1091 potentially data lossy. */
1092 LISP_STRING_TO_EXTERNAL (format_string, formext, Qnative);
1093 if (emacs_strftime (buf, size, formext,
1125 localtime (&value)) 1094 localtime (&value))
1126 || !*buf) 1095 || !*buf)
1127 return build_ext_string (buf, Qbinary); 1096 return build_ext_string (buf, Qnative);
1128 /* If buffer was too small, make it bigger. */ 1097 /* If buffer was too small, make it bigger. */
1129 size *= 2; 1098 size *= 2;
1130 } 1099 }
1131 } 1100 }
1132 1101
1172 else 1141 else
1173 list_args[8] = make_int (difftm (&save_tm, decoded_time)); 1142 list_args[8] = make_int (difftm (&save_tm, decoded_time));
1174 return Flist (9, list_args); 1143 return Flist (9, list_args);
1175 } 1144 }
1176 1145
1177 static void set_time_zone_rule (char *tzstring); 1146 static void set_time_zone_rule (Extbyte *tzstring);
1178 1147
1179 /* from GNU Emacs 21, per Simon Josefsson, modified by stephen 1148 /* from GNU Emacs 21, per Simon Josefsson, modified by stephen
1180 The slight inefficiency is justified since negative times are weird. */ 1149 The slight inefficiency is justified since negative times are weird. */
1181 Lisp_Object 1150 Lisp_Object
1182 make_time (time_t time) 1151 make_time (time_t tiempo)
1183 { 1152 {
1184 return list2 (make_int (time < 0 ? time / 0x10000 : time >> 16), 1153 return list2 (make_int (tiempo < 0 ? tiempo / 0x10000 : tiempo >> 16),
1185 make_int (time & 0xFFFF)); 1154 make_int (tiempo & 0xFFFF));
1186 } 1155 }
1187 1156
1188 DEFUN ("encode-time", Fencode_time, 6, MANY, 0, /* 1157 DEFUN ("encode-time", Fencode_time, 6, MANY, 0, /*
1189 Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time. 1158 Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1190 This is the reverse operation of `decode-time', which see. 1159 This is the reverse operation of `decode-time', which see.
1222 zone = XCAR (zone); 1191 zone = XCAR (zone);
1223 if (NILP (zone)) 1192 if (NILP (zone))
1224 the_time = mktime (&tm); 1193 the_time = mktime (&tm);
1225 else 1194 else
1226 { 1195 {
1227 char tzbuf[100]; 1196 /* #### This business of modifying environ is horrendous!
1228 char *tzstring; 1197 Why don't we just putenv()? Why don't we implement our own
1229 char **oldenv = environ, **newenv; 1198 funs that don't require this futzing? */
1199 Extbyte tzbuf[100];
1200 Extbyte *tzstring;
1201 Extbyte **oldenv = environ, **newenv;
1230 1202
1231 if (STRINGP (zone)) 1203 if (STRINGP (zone))
1232 tzstring = (char *) XSTRING_DATA (zone); 1204 LISP_STRING_TO_EXTERNAL (zone, tzstring, Qnative);
1233 else if (INTP (zone)) 1205 else if (INTP (zone))
1234 { 1206 {
1235 int abszone = abs (XINT (zone)); 1207 int abszone = abs (XINT (zone));
1236 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0), 1208 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
1237 abszone / (60*60), (abszone/60) % 60, abszone % 60); 1209 abszone / (60*60), (abszone/60) % 60, abszone % 60);
1238 tzstring = tzbuf; 1210 tzstring = tzbuf;
1239 } 1211 }
1240 else 1212 else
1241 invalid_argument ("Invalid time zone specification", Qunbound); 1213 invalid_argument ("Invalid time zone specification", Qunbound);
1242 1214
1243 /* Set TZ before calling mktime; merely adjusting mktime's returned 1215 /* Set TZ before calling mktime; merely adjusting mktime's returned
1244 value doesn't suffice, since that would mishandle leap seconds. */ 1216 value doesn't suffice, since that would mishandle leap seconds. */
1245 set_time_zone_rule (tzstring); 1217 set_time_zone_rule (tzstring);
1246 1218
1275 and from `file-attributes'. 1247 and from `file-attributes'.
1276 */ 1248 */
1277 (specified_time)) 1249 (specified_time))
1278 { 1250 {
1279 time_t value; 1251 time_t value;
1280 char *the_ctime; 1252 Intbyte *the_ctime;
1281 EMACS_INT len; /* this is what make_ext_string() accepts; #### 1253 EMACS_INT len; /* this is what make_ext_string() accepts; ####
1282 should it be an Bytecount? */ 1254 should it be an Bytecount? */
1283 1255
1284 if (! lisp_to_time (specified_time, &value)) 1256 if (! lisp_to_time (specified_time, &value))
1285 value = -1; 1257 value = -1;
1286 the_ctime = ctime (&value); 1258 the_ctime = qxe_ctime (&value);
1287 1259
1288 /* ctime is documented as always returning a "\n\0"-terminated 1260 /* ctime is documented as always returning a "\n\0"-terminated
1289 26-byte American time string, but let's be careful anyways. */ 1261 26-byte American time string, but let's be careful anyways. */
1290 for (len = 0; the_ctime[len] != '\n' && the_ctime[len] != '\0'; len++) 1262 for (len = 0; the_ctime[len] != '\n' && the_ctime[len] != '\0'; len++)
1291 ; 1263 ;
1292 1264
1293 return make_ext_string ((Extbyte *) the_ctime, len, Qbinary); 1265 return make_string (the_ctime, len);
1294 } 1266 }
1295 1267
1296 #define TM_YEAR_ORIGIN 1900 1268 #define TM_YEAR_ORIGIN 1900
1297 1269
1298 /* Yield A - B, measured in seconds. */ 1270 /* Yield A - B, measured in seconds. */
1343 if (lisp_to_time (specified_time, &value) 1315 if (lisp_to_time (specified_time, &value)
1344 && (t = gmtime (&value)) != 0) 1316 && (t = gmtime (&value)) != 0)
1345 { 1317 {
1346 struct tm gmt = *t; /* Make a copy, in case localtime modifies *t. */ 1318 struct tm gmt = *t; /* Make a copy, in case localtime modifies *t. */
1347 long offset; 1319 long offset;
1348 char *s, buf[6]; 1320 Extbyte *s;
1321 Lisp_Object tem;
1349 1322
1350 t = localtime (&value); 1323 t = localtime (&value);
1351 offset = difftm (t, &gmt); 1324 offset = difftm (t, &gmt);
1352 s = 0; 1325 s = 0;
1353 #ifdef HAVE_TM_ZONE 1326 #ifdef HAVE_TM_ZONE
1354 if (t->tm_zone) 1327 if (t->tm_zone)
1355 s = (char *)t->tm_zone; 1328 s = (Extbyte *) t->tm_zone;
1356 #else /* not HAVE_TM_ZONE */ 1329 #else /* not HAVE_TM_ZONE */
1357 #ifdef HAVE_TZNAME 1330 #ifdef HAVE_TZNAME
1358 if (t->tm_isdst == 0 || t->tm_isdst == 1) 1331 if (t->tm_isdst == 0 || t->tm_isdst == 1)
1359 s = tzname[t->tm_isdst]; 1332 s = tzname[t->tm_isdst];
1360 #endif 1333 #endif
1361 #endif /* not HAVE_TM_ZONE */ 1334 #endif /* not HAVE_TM_ZONE */
1362 if (!s) 1335 if (s)
1336 tem = build_ext_string (s, Qnative);
1337 else
1363 { 1338 {
1339 Intbyte buf[6];
1340
1364 /* No local time zone name is available; use "+-NNNN" instead. */ 1341 /* No local time zone name is available; use "+-NNNN" instead. */
1365 int am = (offset < 0 ? -offset : offset) / 60; 1342 int am = (offset < 0 ? -offset : offset) / 60;
1366 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60); 1343 qxesprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60,
1367 s = buf; 1344 am%60);
1345 tem = build_intstring (buf);
1368 } 1346 }
1369 return list2 (make_int (offset), build_string (s)); 1347 return list2 (make_int (offset), tem);
1370 } 1348 }
1371 else 1349 else
1372 return list2 (Qnil, Qnil); 1350 return list2 (Qnil, Qnil);
1373 } 1351 }
1374 1352
1381 since if a string in the environment is in readonly 1359 since if a string in the environment is in readonly
1382 storage, it runs afoul of bugs in SVR4 and Solaris 2.3. 1360 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1383 See Sun bugs 1113095 and 1114114, ``Timezone routines 1361 See Sun bugs 1113095 and 1114114, ``Timezone routines
1384 improperly modify environment''. */ 1362 improperly modify environment''. */
1385 1363
1386 static char set_time_zone_rule_tz1[] = "TZ=GMT+0"; 1364 static Char_ASCII set_time_zone_rule_tz1[] = "TZ=GMT+0";
1387 static char set_time_zone_rule_tz2[] = "TZ=GMT+1"; 1365 static Char_ASCII set_time_zone_rule_tz2[] = "TZ=GMT+1";
1388 1366
1389 #endif 1367 #endif
1390 1368
1391 /* Set the local time zone rule to TZSTRING. 1369 /* Set the local time zone rule to TZSTRING.
1392 This allocates memory into `environ', which it is the caller's 1370 This allocates memory into `environ', which it is the caller's
1393 responsibility to free. */ 1371 responsibility to free. */
1394 static void 1372 static void
1395 set_time_zone_rule (char *tzstring) 1373 set_time_zone_rule (Extbyte *tzstring)
1396 { 1374 {
1397 int envptrs; 1375 int envptrs;
1398 char **from, **to, **newenv; 1376 Extbyte **from, **to, **newenv;
1399 1377
1400 for (from = environ; *from; from++) 1378 for (from = environ; *from; from++)
1401 continue; 1379 continue;
1402 envptrs = from - environ + 2; 1380 envptrs = from - environ + 2;
1403 newenv = to = (char **) xmalloc (envptrs * sizeof (char *) 1381 newenv = to = (Extbyte **) xmalloc (envptrs * sizeof (Extbyte *)
1404 + (tzstring ? strlen (tzstring) + 4 : 0)); 1382 + (tzstring ? strlen (tzstring) + 4 : 0));
1405 if (tzstring) 1383 if (tzstring)
1406 { 1384 {
1407 char *t = (char *) (to + envptrs); 1385 Extbyte *t = (Extbyte *) (to + envptrs);
1408 strcpy (t, "TZ="); 1386 strcpy (t, "TZ=");
1409 strcat (t, tzstring); 1387 strcat (t, tzstring);
1410 *to++ = t; 1388 *to++ = t;
1411 } 1389 }
1412 1390
1429 1407
1430 if (tzstring) 1408 if (tzstring)
1431 { 1409 {
1432 /* Temporarily set TZ to a value that loads a tz file 1410 /* Temporarily set TZ to a value that loads a tz file
1433 and that differs from tzstring. */ 1411 and that differs from tzstring. */
1434 char *tz = *newenv; 1412 Extbyte *tz = *newenv;
1435 *newenv = (strcmp (tzstring, set_time_zone_rule_tz1 + 3) == 0 1413 *newenv = (strcmp (tzstring, set_time_zone_rule_tz1 + 3) == 0
1436 ? set_time_zone_rule_tz2 : set_time_zone_rule_tz1); 1414 ? set_time_zone_rule_tz2 : set_time_zone_rule_tz1);
1437 tzset (); 1415 tzset ();
1438 *newenv = tz; 1416 *newenv = tz;
1439 } 1417 }
1460 Set the local time zone using TZ, a string specifying a time zone rule. 1438 Set the local time zone using TZ, a string specifying a time zone rule.
1461 If TZ is nil, use implementation-defined default time zone information. 1439 If TZ is nil, use implementation-defined default time zone information.
1462 */ 1440 */
1463 (tz)) 1441 (tz))
1464 { 1442 {
1465 char *tzstring; 1443 Extbyte *tzstring;
1466 1444
1467 if (NILP (tz)) 1445 if (NILP (tz))
1468 tzstring = 0; 1446 tzstring = 0;
1469 else 1447 else
1470 { 1448 {
1471 CHECK_STRING (tz); 1449 CHECK_STRING (tz);
1472 tzstring = (char *) XSTRING_DATA (tz); 1450 LISP_STRING_TO_EXTERNAL (tz, tzstring, Qnative);
1473 } 1451 }
1474 1452
1475 set_time_zone_rule (tzstring); 1453 set_time_zone_rule (tzstring);
1476 if (environbuf) 1454 if (environbuf)
1477 xfree (environbuf); 1455 xfree (environbuf);
1843 } 1821 }
1844 pos++; 1822 pos++;
1845 } 1823 }
1846 end_multiple_change (buf, mc_count); 1824 end_multiple_change (buf, mc_count);
1847 1825
1848 unbind_to (count, Qnil); 1826 unbind_to (count);
1849 return Qnil; 1827 return Qnil;
1850 } 1828 }
1851 1829
1852 /* #### Shouldn't this also accept a BUFFER argument, in the good old 1830 /* #### Shouldn't this also accept a BUFFER argument, in the good old
1853 XEmacs tradition? */ 1831 XEmacs tradition? */
2185 /* This function can GC */ 2163 /* This function can GC */
2186 int speccount = specpdl_depth (); 2164 int speccount = specpdl_depth ();
2187 2165
2188 record_unwind_protect (save_restriction_restore, save_restriction_save ()); 2166 record_unwind_protect (save_restriction_restore, save_restriction_save ());
2189 2167
2190 return unbind_to (speccount, Fprogn (body)); 2168 return unbind_to_1 (speccount, Fprogn (body));
2191 } 2169 }
2192 2170
2193 2171
2194 DEFUN ("format", Fformat, 1, MANY, 0, /* 2172 DEFUN ("format", Fformat, 1, MANY, 0, /*
2195 Format a string out of a control-string and arguments. 2173 Format a string out of a control-string and arguments.
2264 { 2242 {
2265 /* It should not be necessary to GCPRO ARGS, because 2243 /* It should not be necessary to GCPRO ARGS, because
2266 the caller in the interpreter should take care of that. */ 2244 the caller in the interpreter should take care of that. */
2267 2245
2268 CHECK_STRING (args[0]); 2246 CHECK_STRING (args[0]);
2269 return emacs_doprnt_string_lisp (0, args[0], 0, nargs - 1, args + 1); 2247 return emacs_vsprintf_string_lisp (0, args[0], nargs - 1, args + 1);
2270 } 2248 }
2271 2249
2272 2250
2273 DEFUN ("char-equal", Fchar_equal, 2, 3, 0, /* 2251 DEFUN ("char-equal", Fchar_equal, 2, 3, 0, /*
2274 Return t if two characters match, optionally ignoring case. 2252 Return t if two characters match, optionally ignoring case.
2578 needed to get the desired behavior for atomic extents and unfortunately 2556 needed to get the desired behavior for atomic extents and unfortunately
2579 is not available by any other means. 2557 is not available by any other means.
2580 */ ); 2558 */ );
2581 atomic_extent_goto_char_p = 0; 2559 atomic_extent_goto_char_p = 0;
2582 #ifdef AMPERSAND_FULL_NAME 2560 #ifdef AMPERSAND_FULL_NAME
2583 Fprovide(intern("ampersand-full-name")); 2561 Fprovide (intern ("ampersand-full-name"));
2584 #endif 2562 #endif
2585 2563
2586 DEFVAR_LISP ("user-full-name", &Vuser_full_name /* 2564 DEFVAR_LISP ("user-full-name", &Vuser_full_name /*
2587 *The name of the user. 2565 *The name of the user.
2588 The function `user-full-name', which will return the value of this 2566 The function `user-full-name', which will return the value of this