/* misc.c -- Miscellaneous functions
Copyright (C) 1993, 1994 John Harper <john@dcs.warwick.ac.uk>
$Id: misc.c,v 1.51 2001/09/24 02:50:02 jsh Exp $
This file is part of Jade.
Jade 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 2, or (at your option)
any later version.
Jade 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 Jade; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#define _GNU_SOURCE
#include "repint.h"
#include "build.h"
#include <string.h>
#include <strings.h> /* needed for strncasecmp () on UnixWare */
#include <ctype.h>
#include <stdlib.h>
#include <time.h>
#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif
void (*rep_beep_fun)(void);
DEFSTRING(build_id_string,
BUILD_DATE " by " BUILD_USER "@" BUILD_HOST ", for " HOST_TYPE ".");
DEFSTRING(rep_version_string, REP_VERSION);
DEFSYM(operating_system, "operating-system");
DEFSYM(process_environment, "process-environment");
DEFSYM(rep_version, "rep-version");
DEFSYM(rep_interface_id, "rep-interface-id");
DEFSYM(rep_build_id, "rep-build-id"); /*
::doc:rep.system#operating-system::
A symbol defining the type of operating system that Jade is running
under. Currently this is always the symbol `unix'.
::end::
::doc:process-environment::
A list of all environment variables (as strings "NAME=VALUE") passed
to the interpreter. Also used to specify the environment of subprocesses.
::end::
::doc:rep.system#rep-version::
A string defining the current version of the REP interpreter.
::end::
::doc:rep.system#rep-build-id::
A string describing when, where, and by who the running version of the
LISP interpreter was built.
::end:: */
#ifdef rep_HAVE_UNIX
DEFSYM(unix, "unix");
#endif
DEFSYM(upcase_table, "upcase-table");
DEFSYM(downcase_table, "downcase-table");
DEFSYM(flatten_table, "flatten-table");
/* Some doc strings
::doc:rep.data#upcase-table::
256-byte string holding translations to turn each character into its
upper-case equivalent.
::end::
::doc:rep.data#downcase-table::
256-byte string holding translations to turn each character into its
lower-case equivalent.
::end::
::doc:rep.data#flatten-table::
Translation table to convert newline characters to spaces.
::end:: */
#ifndef HAVE_STPCPY
/*
* copy src to dst, returning pointer to terminating '\0' of dst.
* Although this has a prototype in my <string.h> it doesn't seem to be
* in the actual library??
*/
char *
stpcpy(register char *dst, register const char *src)
{
while((*dst++ = *src++) != 0)
;
return(dst - 1);
}
#endif /* !HAVE_STPCPY */
#ifndef HAVE_STRNCASECMP
/* Compare no more than N characters of S1 and S2,
ignoring case, returning less than, equal to or
greater than zero if S1 is lexicographically less
than, equal to or greater than S2. (from glibc) */
int
strncasecmp (const char *s1, const char *s2, size_t n)
{
const unsigned char *p1 = (const unsigned char *) s1;
const unsigned char *p2 = (const unsigned char *) s2;
unsigned char c1, c2;
if (p1 == p2 || n == 0)
return 0;
do
{
c1 = tolower (*p1++);
c2 = tolower (*p2++);
if (c1 == '\0' || c1 != c2)
return c1 - c2;
} while (--n > 0);
return c1 - c2;
}
#endif
u_char *
rep_str_dupn(const u_char *old, int len)
{
u_char *new = rep_alloc(len + 1);
if(new)
{
memcpy(new, old, len);
new[len] = 0;
}
return new;
}
static void
default_beep (void)
{
fputc (7, stdout);
fflush (stdout);
}
DEFUN_INT("beep", Fbeep, Sbeep, (void), rep_Subr0, "") /*
::doc:rep.system#beep::
beep
Rings a bell.
::end:: */
{
if (rep_beep_fun != 0)
(*rep_beep_fun)();
return Qt;
}
DEFUN("complete-string", Fcomplete_string, Scomplete_string,
(repv existing, repv arg_list, repv fold), rep_Subr3) /*
::doc:rep.data#complete-string::
complete-string TEMPLATE LIST [FOLD-CASE]
Return a string whose beginning matches the string TEMPLATE, and is unique
in the set of all strings in LIST which also match TEMPLATE. If FOLD-CASE
is t, all matching ignores character case.
::end:: */
{
u_char *orig, *match = NULL;
int matchlen = 0, origlen;
rep_DECLARE1(existing, rep_STRINGP);
rep_DECLARE2(arg_list, rep_LISTP);
orig = rep_STR(existing);
origlen = rep_STRING_LEN(existing);
while(rep_CONSP(arg_list))
{
repv arg = rep_CAR(arg_list);
if(rep_STRINGP(arg))
{
u_char *tmp = rep_STR(arg);
if((rep_NILP(fold)
? strncmp (orig, tmp, origlen)
: strncasecmp (orig, tmp, origlen)) == 0)
{
if(match)
{
u_char *tmp2 = match + origlen;
tmp += origlen;
while(*tmp2 && *tmp)
{
if(rep_NILP(fold)
? (*tmp2 != *tmp)
: (tolower(*tmp2) != tolower(*tmp)))
{
break;
}
tmp2++; tmp++;
}
if((tmp2 - match) < matchlen)
matchlen = tmp2 - match;
}
else
{
match = tmp;
matchlen = strlen(tmp);
}
}
}
arg_list = rep_CDR(arg_list);
}
if(match)
return rep_string_dupn(match, matchlen);
else
return Qnil;
}
DEFUN("current-time", Fcurrent_time, Scurrent_time, (void), rep_Subr0) /*
::doc:rep.system#current-time::
current-time
Return a value denoting the current system time. This will be a cons cell
containing (DAYS . SECONDS), the number of DAYS since the epoch, and the
number of seconds since the start of the day (universal time).
::end:: */
{
u_long time = rep_time();
return rep_MAKE_TIME(time);
}
DEFUN("current-utime", Fcurrent_utime, Scurrent_utime, (void), rep_Subr0) /*
::doc:rep.system#current-utime::
current-utime
Return the current time in microseconds.
::end:: */
{
rep_long_long time = rep_utime ();
return rep_make_longlong_int (time);
}
DEFUN("fix-time", Ffix_time, Sfix_time, (repv time), rep_Subr1) /*
::doc:rep.system#fix-time::
fix-time TIMESTAMP
Ensure that the two parts of TIMESTAMP are mutually consistent. If not
TIMESTAMP is altered. Returns TIMESTAMP.
::end:: */
{
u_long timestamp;
rep_DECLARE1(time, rep_TIMEP);
timestamp = rep_GET_TIME(time);
rep_CAR(time) = rep_MAKE_INT(timestamp / 86400);
rep_CDR(time) = rep_MAKE_INT(timestamp % 86400);
return time;
}
DEFUN("current-time-string", Fcurrent_time_string,
Scurrent_time_string, (repv time, repv format), rep_Subr2) /*
::doc:rep.system#current-time-string::
current-time-string [TIME] [FORMAT]
Returns a human-readable string defining the current date and time, or if
specified, that defining TIME.
If defined, FORMAT is a string defining how to create the string. It has
the same conventions as the template to the C library's strftime function.
::end:: */
{
time_t timestamp;
if(rep_TIMEP(time))
timestamp = rep_GET_TIME(time);
else
timestamp = rep_time();
if(rep_STRINGP(format))
{
struct tm *loctime = localtime(×tamp);
char buf[256];
int len = strftime(buf, sizeof(buf), rep_STR(format), loctime);
if(len > 0)
return rep_string_dupn(buf, len);
else
return rep_null_string ();
}
else
{
char *str = ctime(×tamp);
if(str != 0)
return rep_string_dupn(str, strlen(str) - 1);
else
return rep_null_string ();
}
}
DEFUN("time-later-p", Ftime_later_p, Stime_later_p, (repv t1, repv t2), rep_Subr2) /*
::doc:rep.system#time-later-p::
time-later-p TIME-STAMP1 TIME-STAMP2
Returns t when TIME-STAMP1 refers to a later time than TIME-STAMP2.
::end:: */
{
u_long time1, time2;
rep_DECLARE1(t1, rep_TIMEP);
rep_DECLARE2(t2, rep_TIMEP);
time1 = rep_GET_TIME(t1);
time2 = rep_GET_TIME(t2);
return time1 > time2 ? Qt : Qnil;
}
DEFUN("sleep-for", Fsleep_for, Ssleep_for, (repv secs, repv msecs),
rep_Subr2) /*
::doc:rep.system#sleep-for::
sleep-for SECONDS [MILLISECONDS]
Pause for SECONDS (plus the optional MILLISECOND component) length of time.
::end:: */
{
rep_DECLARE1(secs, rep_NUMERICP);
rep_DECLARE2_OPT(msecs, rep_NUMERICP);
rep_sleep_for(rep_get_long_int (secs), rep_get_long_int (msecs));
return Qt;
}
DEFUN("sit-for", Fsit_for, Ssit_for, (repv secs, repv msecs),
rep_Subr2) /*
::doc:rep.system#sit-for::
sit-for [SECONDS] [MILLISECONDS]
Wait for input to arrive and be processed. No more than SECONDS seconds plus
MILLISECONDS milliseconds will be waited. If at the end of this time no
input has arrived, return t. Otherwise return nil if input was found.
If neither SECONDS nor MILLISECONDS is defined the command will return
immediately, using a null timeout.
::end:: */
{
rep_DECLARE1_OPT(secs, rep_NUMERICP);
rep_DECLARE2_OPT(msecs, rep_NUMERICP);
return rep_sit_for(((rep_get_long_int (secs)) * 1000)
+ rep_get_long_int (msecs));
}
DEFUN("user-login-name", Fuser_login_name, Suser_login_name, (void), rep_Subr0) /*
::doc:rep.system#user-login-name::
user-login-name
Returns the login name of the user (a string).
::end:: */
{
return rep_user_login_name();
}
DEFUN("user-full-name", Fuser_full_name, Suser_full_name, (repv arg), rep_Subr1) /*
::doc:rep.system#user-full-name::
user-full-name [REAL-NAME]
Returns the real name of the user (a string). If REAL-NAME is non-nil, it's
the name to return in subsequent calls.
::end:: */
{
static repv saved_name;
rep_DECLARE1_OPT (arg, rep_STRINGP);
if(arg != Qnil)
{
if(!saved_name)
rep_mark_static(&saved_name);
saved_name = arg;
}
return saved_name ? saved_name : rep_user_full_name();
}
DEFUN("user-home-directory", Fuser_home_directory,
Suser_home_directory, (repv user), rep_Subr1) /*
::doc:rep.system#user-home-directory::
user-home-directory [USER]
Return the path to USER's home directory (a string). When USER is undefined
the directory of the user who executed Jade is found.
::end:: */
{
rep_DECLARE1_OPT(user, rep_STRINGP);
return rep_user_home_directory(user);
}
DEFUN("system-name", Fsystem_name, Ssystem_name, (void), rep_Subr0) /*
::doc:rep.system#system-name::
system-name
Returns the name of the host which the editor is running on.
::end:: */
{
return rep_system_name();
}
DEFUN("message", Fmessage, Smessage, (repv string, repv now), rep_Subr2) /*
::doc:rep.system#message::
message STRING [DISPLAY-NOW]
Temporarily sets the status display to STRING, this may not happen until the
next complete redisplay, unless DISPLAY-NOW is non-nil.
::end:: */
{
rep_DECLARE1(string, rep_STRINGP);
if (rep_message_fun != 0)
{
(*rep_message_fun)(rep_message, rep_STR(string));
if(!rep_NILP(now))
(*rep_message_fun)(rep_redisplay_message);
}
return string;
}
DEFUN("translate-string", Ftranslate_string, Stranslate_string, (repv string, repv table), rep_Subr2) /*
::doc:rep.data#translate-string:
translate-string STRING TRANSLATION-TABLE
Applies the TRANSLATION-TABLE to each character in the string STRING.
TRANSLATION-TABLE is a string, each character represents the translation
for an ascii character of that characters position in the string. If the
string is less than 256 chars long any undefined characters will remain
unchanged.
Note that the STRING really is modified, no copy is made!
::end:: */
{
int tablen, slen;
register u_char *str;
rep_DECLARE1(string, rep_STRINGP);
rep_DECLARE2(table, rep_STRINGP);
tablen = rep_STRING_LEN(table);
if(!rep_STRING_WRITABLE_P(string))
return(rep_signal_arg_error(string, 1));
str = rep_STR(string);
slen = rep_STRING_LEN(string);
while(slen-- > 0)
{
register u_char c = *str;
*str++ = (c < tablen) ? rep_STR(table)[c] : c;
}
rep_string_modified (string);
return(string);
}
DEFUN("alpha-char-p", Falpha_char_p, Salpha_char_p, (repv ch), rep_Subr1) /*
::doc:rep.data#alpha-char-p::
alpha-char-p CHAR
Returns t if CHAR is an alphabetic character.
::end:: */
{
return (rep_INTP(ch) && isalpha(rep_INT(ch))) ? Qt : Qnil;
}
DEFUN("upper-case-p", Fupper_case_p, Supper_case_p, (repv ch), rep_Subr1) /*
::doc:rep.data#upper-case-p::
upper-case-p CHAR
Returns t if CHAR is upper case.
::end:: */
{
return (rep_INTP(ch) && isupper(rep_INT(ch))) ? Qt : Qnil;
}
DEFUN("lower-case-p", Flower_case_p, Slower_case_p, (repv ch), rep_Subr1) /*
::doc:rep.data#lower-case-p::
lower-case-p CHAR
Returns t if CHAR is lower case.
::end:: */
{
return (rep_INTP(ch) && islower(rep_INT(ch))) ? Qt : Qnil;
}
DEFUN("digit-char-p", Fdigit_char_p, Sdigit_char_p, (repv ch), rep_Subr1) /*
::doc:rep.data#digit-char-p::
digit-char-p CHAR
Returns t if CHAR is a digit.
::end:: */
{
return (rep_INTP(ch) && isdigit(rep_INT(ch))) ? Qt : Qnil;
}
DEFUN("alphanumericp", Falphanumericp, Salphanumericp, (repv ch), rep_Subr1) /*
::doc:rep.data#alphanumericp::
alphanumericp CHAR
Returns t if CHAR is alpha-numeric.
::end:: */
{
return (rep_INTP(ch) && isalnum(rep_INT(ch))) ? Qt : Qnil;
}
DEFUN("space-char-p", Fspace_char_p, Sspace_char_p, (repv ch), rep_Subr1) /*
::doc:rep.data#space-char-p::
space-char-p CHAR
Returns t if CHAR is whitespace.
::end:: */
{
return (rep_INTP(ch) && isspace(rep_INT(ch))) ? Qt : Qnil;
}
DEFUN("char-upcase", Fchar_upcase, Schar_upcase, (repv ch), rep_Subr1) /*
::doc:rep.data#char-upcase::
char-upcase CHAR
Returns the upper-case equivalent of CHAR.
::end:: */
{
rep_DECLARE1(ch, rep_INTP);
return rep_MAKE_INT(toupper(rep_INT(ch)));
}
DEFUN("char-downcase", Fchar_downcase, Schar_downcase, (repv ch), rep_Subr1) /*
::doc:rep.data#char-downcase::
char-downcase CHAR
Returns the lower-case equivalent of CHAR.
::end:: */
{
rep_DECLARE1(ch, rep_INTP);
return rep_MAKE_INT(tolower(rep_INT(ch)));
}
DEFUN_INT("system", Fsystem, Ssystem, (repv command), rep_Subr1, "sShell command:") /*
::doc:rep.system#system::
system SHELL-COMMAND
Synchronously execute the shell command string SHELL-COMMAND. Returns the
exit status of the command, or signals an error if the shell couldn't
be started.
Note that the exit status is _not_ the same as the return code. It
depends on the operating system, but under unix the return code may be
found by right-shifting the exit status by eight bits. Low non-zero
values represent that the process was killed by a signal.
::end:: */
{
rep_DECLARE1(command, rep_STRINGP);
return rep_system (rep_STR (command));
}
DEFUN("get-command-line-option", Fget_command_line_option,
Sget_command_line_option, (repv opt, repv arg), rep_Subr2) /*
::doc:rep.system#get-command-line-option::
get-command-line-option OPTION [REQUIRES-ARGUMENT]
Returns t if OPTION was specified on the command line (OPTION is typically
a word beginning with `--'). If REQUIRES-ARGUMENT is non-nil, this option
requires a parameter, the value of which is returned. If a parameters isn't
supplied an error is signalled.
::end:: */
{
repv param = Qt;
rep_DECLARE1(opt, rep_STRINGP);
if (rep_get_option (rep_STR(opt), (arg == Qnil) ? 0 : ¶m))
return param;
else
return Qnil;
}
DEFUN ("crypt", Fcrypt, Scrypt, (repv key, repv salt), rep_Subr2) /*
::doc:rep.system#crypt::
crypt KEY SALT
The `crypt' function takes a password, KEY, as a string, and a SALT
character array, and returns a printable ASCII string which starts with
another salt. It is believed that, given the output of the function,
the best way to find a KEY that will produce that output is to guess
values of KEY until the original value of KEY is found.
See crypt(3) for more information.
::end:: */
{
const char *output;
rep_DECLARE1 (key, rep_STRINGP);
rep_DECLARE2 (salt, rep_STRINGP);
#ifdef HAVE_CRYPT
output = crypt (rep_STR (key), rep_STR (salt));
return rep_string_dup (output);
#else
{ DEFSTRING (err, "crypt () isn't supported on this system");
return Fsignal (Qerror, rep_LIST_1 (rep_VAL (&err))); }
#endif
}
void
rep_misc_init(void)
{
int i;
repv tem;
if (rep_beep_fun == 0)
rep_beep_fun = default_beep;
tem = rep_push_structure ("rep.system");
rep_INTERN(operating_system);
#ifdef rep_HAVE_UNIX
rep_INTERN(unix);
Fset (Qoperating_system, Qunix);
#endif
rep_INTERN_SPECIAL(process_environment);
Fset (Qprocess_environment, Qnil);
rep_INTERN(rep_version);
Fset (Qrep_version, rep_VAL(&rep_version_string));
rep_INTERN(rep_interface_id);
Fset (Qrep_interface_id, rep_VAL(rep_MAKE_INT(rep_INTERFACE)));
rep_INTERN(rep_build_id);
Fset (Qrep_build_id, rep_VAL(&build_id_string));
rep_ADD_SUBR_INT(Sbeep);
rep_ADD_SUBR(Scurrent_time);
rep_ADD_SUBR(Scurrent_utime);
rep_ADD_SUBR(Sfix_time);
rep_ADD_SUBR(Scurrent_time_string);
rep_ADD_SUBR(Stime_later_p);
rep_ADD_SUBR(Ssleep_for);
rep_ADD_SUBR(Ssit_for);
rep_ADD_SUBR(Sget_command_line_option);
rep_ADD_SUBR(Scrypt);
rep_ADD_SUBR_INT(Ssystem);
rep_ADD_SUBR(Suser_login_name);
rep_ADD_SUBR(Suser_full_name);
rep_ADD_SUBR(Suser_home_directory);
rep_ADD_SUBR(Ssystem_name);
rep_ADD_SUBR(Smessage);
rep_pop_structure (tem);
tem = rep_push_structure ("rep.data");
rep_ADD_SUBR(Stranslate_string);
rep_ADD_SUBR(Salpha_char_p);
rep_ADD_SUBR(Supper_case_p);
rep_ADD_SUBR(Slower_case_p);
rep_ADD_SUBR(Sdigit_char_p);
rep_ADD_SUBR(Salphanumericp);
rep_ADD_SUBR(Sspace_char_p);
rep_ADD_SUBR(Schar_upcase);
rep_ADD_SUBR(Schar_downcase);
rep_ADD_SUBR(Scomplete_string);
{
repv up = rep_make_string (257);
repv down = rep_make_string (257);
for(i = 0; i < 256; i++)
{
rep_STR(up)[i] = toupper(i);
rep_STR(down)[i] = tolower(i);
}
rep_STR(up)[256] = 0;
rep_STR(down)[256] = 0;
rep_INTERN(upcase_table);
rep_INTERN(downcase_table);
Fset (Qupcase_table, up);
Fset (Qdowncase_table, down);
}
{
repv flatten = rep_make_string (12);
for(i = 0; i < 10; i++)
rep_STR(flatten)[i] = i;
rep_STR(flatten)[10] = ' ';
rep_STR(flatten)[11] = 0;
rep_INTERN(flatten_table);
Fset (Qflatten_table, flatten);
}
rep_pop_structure (tem);
}
syntax highlighted by Code2HTML, v. 0.9.1