See patch #19.
-/* $Header: cons.c,v 3.0.1.6 90/03/27 15:35:21 lwall Locked $
+/* $Header: cons.c,v 3.0.1.7 90/08/09 02:35:52 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cons.c,v $
+ * Revision 3.0.1.7 90/08/09 02:35:52 lwall
+ * patch19: did preliminary work toward debugging packages and evals
+ * patch19: Added support for linked-in C subroutines
+ * patch19: Numeric literals are now stored only in floating point
+ * patch19: Added -c switch to do compilation only
+ *
* Revision 3.0.1.6 90/03/27 15:35:21 lwall
* patch16: formats didn't work inside eval
* patch16: $foo++ now optimized to ++$foo where value not required
Newz(101,sub,1,SUBR);
if (stab_sub(stab)) {
if (dowarn) {
- line_t oldline = line;
+ CMD *oldcurcmd = curcmd;
if (cmd)
- line = cmd->c_line;
+ curcmd = cmd;
warn("Subroutine %s redefined",name);
- line = oldline;
+ curcmd = oldcurcmd;
+ }
+ if (stab_sub(stab)->cmd) {
+ cmd_free(stab_sub(stab)->cmd);
+ afree(stab_sub(stab)->tosave);
}
- cmd_free(stab_sub(stab)->cmd);
- afree(stab_sub(stab)->tosave);
Safefree(stab_sub(stab));
}
sub->filename = filename;
STR *str = str_nmake((double)subline);
str_cat(str,"-");
- sprintf(buf,"%ld",(long)line);
+ sprintf(buf,"%ld",(long)curcmd->c_line);
str_cat(str,buf);
name = str_get(subname);
hstore(stab_xhash(DBsub),name,strlen(name),str,0);
return sub;
}
+SUBR *
+make_usub(name, ix, subaddr, filename)
+char *name;
+int ix;
+int (*subaddr)();
+char *filename;
+{
+ register SUBR *sub;
+ STAB *stab = stabent(name,allstabs);
+
+ if (!stab) /* unused function */
+ return;
+ Newz(101,sub,1,SUBR);
+ if (stab_sub(stab)) {
+ if (dowarn)
+ warn("Subroutine %s redefined",name);
+ if (stab_sub(stab)->cmd) {
+ cmd_free(stab_sub(stab)->cmd);
+ afree(stab_sub(stab)->tosave);
+ }
+ Safefree(stab_sub(stab));
+ }
+ sub->filename = filename;
+ sub->usersub = subaddr;
+ sub->userindex = ix;
+ stab_sub(stab) = sub;
+ return sub;
+}
+
make_form(stab,fcmd)
STAB *stab;
FCMD *fcmd;
cmd->c_line = head->c_line;
cmd->c_label = head->c_label;
cmd->c_file = filename;
+ cmd->c_pack = curpack;
return append_line(cmd, cur);
}
if (cond)
cmd->c_flags |= CF_COND;
if (cmdline == NOLINE)
- cmd->c_line = line;
+ cmd->c_line = curcmd->c_line;
else {
cmd->c_line = cmdline;
cmdline = NOLINE;
}
cmd->c_file = filename;
+ cmd->c_pack = curpack;
if (perldb)
cmd = dodb(cmd);
return cmd;
if (arg)
cmd->c_flags |= CF_COND;
if (cmdline == NOLINE)
- cmd->c_line = line;
+ cmd->c_line = curcmd->c_line;
else {
cmd->c_line = cmdline;
cmdline = NOLINE;
if (arg)
cmd->c_flags |= CF_COND;
if (cmdline == NOLINE)
- cmd->c_line = line;
+ cmd->c_line = curcmd->c_line;
else {
cmd->c_line = cmdline;
cmdline = NOLINE;
arg->arg_type == O_SLT || arg->arg_type == O_SGT) {
if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
if (arg[2].arg_type == A_SINGLE) {
+ char *junk = str_get(arg[2].arg_ptr.arg_str);
+
cmd->c_stab = arg[1].arg_ptr.arg_stab;
cmd->c_short = str_smake(arg[2].arg_ptr.arg_str);
cmd->c_slen = cmd->c_short->str_cur+1;
else
(void)sprintf(tname,"next char %c",yychar);
(void)sprintf(buf, "%s in file %s at line %d, %s\n",
- s,filename,line,tname);
- if (line == multi_end && multi_start < multi_end)
+ s,filename,curcmd->c_line,tname);
+ if (curcmd->c_line == multi_end && multi_start < multi_end)
sprintf(buf+strlen(buf),
" (Might be a runaway multi-line %c%c string starting on line %d)\n",
multi_open,multi_close,multi_start);
else
fputs(buf,stderr);
if (++error_count >= 10)
- fatal("Too many errors\n");
+ fatal("%s has too many errors.\n", filename);
}
void
}
tofree = cmd;
cmd = cmd->c_next;
- Safefree(tofree);
+ if (tofree != head) /* to get Saber to shut up */
+ Safefree(tofree);
if (cmd && cmd == head) /* reached end of while loop */
break;
}
+ Safefree(head);
}
arg_free(arg)
-/* $Header: consarg.c,v 3.0.1.5 90/03/27 15:36:45 lwall Locked $
+/* $Header: consarg.c,v 3.0.1.6 90/08/09 02:38:51 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: consarg.c,v $
+ * Revision 3.0.1.6 90/08/09 02:38:51 lwall
+ * patch19: fixed problem with % of negative number
+ *
* Revision 3.0.1.5 90/03/27 15:36:45 lwall
* patch16: support for machines that can't cast negative floats to unsigned ints
*
arg_free(limarg);
}
else {
+ arg[3].arg_flags = 0;
arg[3].arg_type = A_EXPR;
arg[3].arg_ptr.arg_arg = limarg;
}
arg->arg_len = 1;
arg[1].arg_type = A_ARYSTAB; /* $abc[123] is hoistable now */
arg[1].arg_len = i;
- arg[1].arg_ptr = arg[1].arg_ptr; /* get stab pointer */
str_free(s2);
}
/* FALL THROUGH */
if (tmp2 >= 0)
str_numset(str,(double)(tmp2 % tmplong));
else
- str_numset(str,(double)(tmplong - (-tmp2 % tmplong)));
+ str_numset(str,(double)(tmplong - ((-tmp2 - 1) % tmplong))) - 1;
#else
tmp2 = tmp2;
#endif
if (arg->arg_len == 0)
arg[1].arg_type = A_NULL;
arg->arg_len = 2;
+ arg[2].arg_flags = 0;
arg[2].arg_ptr.arg_hash = curstash;
arg[2].arg_type = A_NULL;
return arg;
-/* $Header: doarg.c,v 3.0.1.5 90/03/27 15:39:03 lwall Locked $
+/* $Header: doarg.c,v 3.0.1.6 90/08/09 02:48:38 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: doarg.c,v $
+ * Revision 3.0.1.6 90/08/09 02:48:38 lwall
+ * patch19: fixed double include of <signal.h>
+ * patch19: pack/unpack can now do native float and double
+ * patch19: pack/unpack can now have absolute and negative positioning
+ * patch19: pack/unpack can now have use * to specify all the rest of input
+ * patch19: unpack can do checksumming
+ * patch19: $< and $> better supported on machines without setreuid
+ * patch19: Added support for linked-in C subroutines
+ *
* Revision 3.0.1.5 90/03/27 15:39:03 lwall
* patch16: MSDOS support
* patch16: support for machines that can't cast negative floats to unsigned ints
#include "EXTERN.h"
#include "perl.h"
+#ifndef NSIG
#include <signal.h>
+#endif
extern unsigned char fold[];
if (spat->spat_regexp)
regfree(spat->spat_regexp);
spat->spat_regexp = regcomp(m,m+dstr->str_cur,
- spat->spat_flags & SPAT_FOLD,1);
+ spat->spat_flags & SPAT_FOLD);
if (spat->spat_flags & SPAT_KEEP) {
arg_free(spat->spat_runtime); /* it won't change, so */
spat->spat_runtime = Nullarg; /* no point compiling again */
long along;
unsigned long aulong;
char *aptr;
+ float afloat;
+ double adouble;
items = arglast[2] - sp;
st += ++sp;
while (pat < patend) {
#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
datumtype = *pat++;
- if (isdigit(*pat)) {
+ if (*pat == '*') {
+ len = index("@Xxu",datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isdigit(*pat)) {
len = *pat++ - '0';
while (isdigit(*pat))
len = (len * 10) + (*pat++ - '0');
switch(datumtype) {
default:
break;
+ case '%':
+ fatal("% may only be used in unpack");
+ case '@':
+ len -= str->str_cur;
+ if (len > 0)
+ goto grow;
+ len = -len;
+ if (len > 0)
+ goto shrink;
+ break;
+ case 'X':
+ shrink:
+ str->str_cur -= len;
+ if (str->str_cur < 0)
+ fatal("X outside of string");
+ str->str_ptr[str->str_cur] = '\0';
+ break;
case 'x':
+ grow:
while (len >= 10) {
str_ncat(str,null10,10);
len -= 10;
case 'a':
fromstr = NEXTFROM;
aptr = str_get(fromstr);
+ if (pat[-1] == '*')
+ len = fromstr->str_cur;
if (fromstr->str_cur > len)
str_ncat(str,aptr,len);
else {
str_ncat(str,&achar,sizeof(char));
}
break;
+ /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ afloat = (float)str_gnum(fromstr);
+ str_ncat(str, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)str_gnum(fromstr);
+ str_ncat(str, (char *)&adouble, sizeof (double));
+ }
+ break;
case 'n':
while (len-- > 0) {
fromstr = NEXTFROM;
str_ncat(str,(char*)&aptr,sizeof(char*));
}
break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = str_get(fromstr);
+ aint = fromstr->str_cur;
+ STR_GROW(str,aint * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (aint > 0) {
+ int todo;
+
+ if (aint > len)
+ todo = len;
+ else
+ todo = aint;
+ doencodes(str, aptr, todo);
+ aint -= todo;
+ aptr += todo;
+ }
+ break;
}
}
STABSET(str);
}
#undef NEXTFROM
+doencodes(str, s, len)
+register STR *str;
+register char *s;
+register int len;
+{
+ char hunk[5];
+
+ *hunk = len + ' ';
+ str_ncat(str, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 0) {
+ hunk[0] = ' ' + (077 & (*s >> 2));
+ hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
+ hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
+ hunk[3] = ' ' + (077 & (s[2] & 077));
+ str_ncat(str, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ str_ncat(str, "\n", 1);
+}
+
void
do_sprintf(str,len,sarg)
register STR *str;
}
if (!stab)
fatal("Undefined subroutine called");
+ saveint(&wantarray);
+ wantarray = gimme;
sub = stab_sub(stab);
if (!sub)
fatal("Undefined subroutine \"%s\" called", stab_name(stab));
+ if (sub->usersub) {
+ st[sp] = arg->arg_ptr.arg_str;
+ if ((arg[2].arg_type & A_MASK) == A_NULL)
+ items = 0;
+ return sub->usersub(sub->userindex,sp,items);
+ }
if ((arg[2].arg_type & A_MASK) != A_NULL) {
savearray = stab_xarray(defstab);
stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
}
savelong(&sub->depth);
sub->depth++;
- saveint(&wantarray);
- wantarray = gimme;
if (sub->depth >= 2) { /* save temporaries on recursion? */
if (sub->depth == 100 && dowarn)
warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
}
if (!stab)
fatal("Undefined subroutine called");
- sub = stab_sub(stab);
- if (!sub)
- fatal("Undefined subroutine \"%s\" called", stab_name(stab));
+ saveint(&wantarray);
+ wantarray = gimme;
/* begin differences */
str = stab_val(DBsub);
saveitem(str);
}
savelong(&sub->depth);
sub->depth++;
- saveint(&wantarray);
- wantarray = gimme;
if (sub->depth >= 2) { /* save temporaries on recursion? */
if (sub->depth == 100 && dowarn)
warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
}
}
if (delaymagic > 1) {
+ if (delaymagic & DM_REUID) {
#ifdef SETREUID
- if (delaymagic & DM_REUID)
setreuid(uid,euid);
+#else
+ if (uid != euid || setuid(uid) < 0)
+ fatal("No setreuid available");
#endif
+ }
+ if (delaymagic & DM_REGID) {
#ifdef SETREGID
- if (delaymagic & DM_REGID)
setregid(gid,egid);
+#else
+ if (gid != egid || setgid(gid) < 0)
+ fatal("No setregid available");
#endif
+ }
}
delaymagic = 0;
localizing = FALSE;
retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0;
else if (type == O_HASH || type == O_LHASH)
retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0;
- else if (type == O_SUBR || type == O_DBSUBR)
- retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
else if (type == O_ASLICE || type == O_LASLICE)
retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0;
else if (type == O_HSLICE || type == O_LHSLICE)
retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0;
+ else if (type == O_SUBR || type == O_DBSUBR)
+ retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
else
retval = FALSE;
str_numset(str,(double)retval);
-/* $Header: doio.c,v 3.0.1.8 90/03/27 15:44:02 lwall Locked $
+/* $Header: doio.c,v 3.0.1.9 90/08/09 02:56:19 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: doio.c,v $
+ * Revision 3.0.1.9 90/08/09 02:56:19 lwall
+ * patch19: various MSDOS and OS/2 patches folded in
+ * patch19: prints now check error status better
+ * patch19: printing a list with null elements only printed front of list
+ * patch19: on machines with vfork child would allocate memory in parent
+ * patch19: getsockname and getpeername gave bogus warning on error
+ * patch19: MACH doesn't have seekdir or telldir
+ *
* Revision 3.0.1.8 90/03/27 15:44:02 lwall
* patch16: MSDOS support
* patch16: support for machines that can't cast negative floats to unsigned ints
#ifdef I_UTIME
#include <utime.h>
#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
bool
do_open(stab,name,len)
fileuid = statbuf.st_uid;
filegid = statbuf.st_gid;
if (*inplace) {
+#ifdef SUFFIX
+ add_suffix(str,inplace);
+#else
str_cat(str,inplace);
+#endif
#ifdef RENAME
+#ifndef MSDOS
(void)rename(oldname,str->str_ptr);
#else
+ do_close(stab,FALSE);
+ (void)unlink(str->str_ptr);
+ (void)rename(oldname,str->str_ptr);
+ do_open(stab,str->str_ptr,stab_val(stab)->str_cur);
+#endif /* MSDOS */
+#else
(void)UNLINK(str->str_ptr);
(void)link(oldname,str->str_ptr);
(void)UNLINK(oldname);
#endif
}
else {
+#ifndef MSDOS
(void)UNLINK(oldname);
+#else
+ fatal("Can't do inplace edit without backup");
+#endif
}
str_nset(str,">",1);
retval = 256; /* otherwise guess at what's safe */
#endif
if (argstr->str_cur < retval) {
- str_grow(argstr,retval+1);
+ Str_Grow(argstr,retval+1);
argstr->str_cur = retval;
}
}
int
+do_truncate(str,arg,gimme,arglast)
+STR *str;
+register ARG *arg;
+int gimme;
+int *arglast;
+{
+ register ARRAY *ary = stack;
+ register int sp = arglast[0] + 1;
+ off_t len = (off_t)str_gnum(ary->ary_array[sp+1]);
+ int result = 1;
+ STAB *tmpstab;
+
+#if defined(TRUNCATE) || defined(CHSIZE) || defined(F_FREESP)
+#ifdef TRUNCATE
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_io(tmpstab) ||
+ ftruncate(fileno(stab_io(tmpstab)->ifp), len) < 0)
+ result = 0;
+ }
+ else if (truncate(str_get(ary->ary_array[sp]), len) < 0)
+ result = 0;
+#else
+#ifndef CHSIZE
+#define chsize(f,l) fcntl(f,F_FREESP,l)
+#endif
+ if ((arg[1].arg_type & A_MASK) == A_WORD) {
+ tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_io(tmpstab) ||
+ chsize(fileno(stab_io(tmpstab)->ifp), len) < 0)
+ result = 0;
+ }
+ else {
+ int tmpfd;
+
+ if ((tmpfd = open(str_get(ary->ary_array[sp]), 0)) < 0)
+ result = 0;
+ else {
+ if (chsize(tmpfd, len) < 0)
+ result = 0;
+ close(tmpfd);
+ }
+ }
+#endif
+
+ if (result)
+ str_sset(str,&str_yes);
+ else
+ str_sset(str,&str_undef);
+ STABSET(str);
+ ary->ary_array[sp] = str;
+ return sp;
+#else
+ fatal("truncate not implemented");
+#endif
+}
+
+int
looks_like_number(str)
STR *str;
{
return FALSE;
}
if (!str)
- return FALSE;
+ return TRUE;
if (ofmt &&
((str->str_nok && str->str_u.str_nval != 0.0)
- || (looks_like_number(str) && str_gnum(str) != 0.0) ) )
+ || (looks_like_number(str) && str_gnum(str) != 0.0) ) ) {
fprintf(fp, ofmt, str->str_u.str_nval);
+ return !ferror(fp);
+ }
else {
tmps = str_get(str);
if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'a' && tmps[3] == 'b'
str = ((STAB*)str)->str_magic;
putc('*',fp);
}
- if (str->str_cur && fwrite(tmps,1,str->str_cur,fp) == 0)
+ if (str->str_cur && (fwrite(tmps,1,str->str_cur,fp) == 0 || ferror(fp)))
return FALSE;
}
return TRUE;
retval = (items <= 0);
for (; items > 0; items--,st++) {
if (retval && ofslen) {
- if (fwrite(ofs, 1, ofslen, fp) == 0) {
+ if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
retval = FALSE;
break;
}
break;
}
if (retval && orslen)
- if (fwrite(ors, 1, orslen, fp) == 0)
+ if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
retval = FALSE;
}
return retval;
return FALSE;
}
+static char **Argv = Null(char **);
+static char *Cmd = Nullch;
+
+int
+do_execfree()
+{
+ if (Argv) {
+ Safefree(Argv);
+ Argv = Null(char **);
+ }
+ if (Cmd) {
+ Safefree(Cmd);
+ Cmd = Nullch;
+ }
+}
+
bool
do_exec(cmd)
char *cmd;
{
register char **a;
register char *s;
- char **argv;
char flags[10];
- char *cmd2;
#ifdef TAINT
taintenv();
return FALSE;
}
}
- New(402,argv, (s - cmd) / 2 + 2, char*);
- cmd2 = nsavestr(cmd, s-cmd);
- a = argv;
- for (s = cmd2; *s;) {
+ New(402,Argv, (s - cmd) / 2 + 2, char*);
+ Cmd = nsavestr(cmd, s-cmd);
+ a = Argv;
+ for (s = Cmd; *s;) {
while (*s && isspace(*s)) s++;
if (*s)
*(a++) = s;
*s++ = '\0';
}
*a = Nullch;
- if (argv[0]) {
- execvp(argv[0],argv);
+ if (Argv[0]) {
+ execvp(Argv[0],Argv);
if (errno == ENOEXEC) { /* for system V NIH syndrome */
- Safefree(argv);
- Safefree(cmd2);
+ do_execfree();
goto doshell;
}
}
- Safefree(cmd2);
- Safefree(argv);
+ do_execfree();
return FALSE;
}
switch (optype) {
case O_GETSOCKNAME:
if (getsockname(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0)
- goto nuts;
+ goto nuts2;
break;
case O_GETPEERNAME:
if (getpeername(fd, st[sp]->str_ptr, &st[sp]->str_cur) < 0)
- goto nuts;
+ goto nuts2;
break;
}
nuts:
if (dowarn)
warn("get{sock,peer}name() on closed fd");
+nuts2:
st[sp] = &str_undef;
return sp;
return sp;
}
+#endif /* SOCKET */
+
+#ifdef SELECT
int
do_select(gimme,arglast)
int gimme;
j = str->str_len;
if (j < growsize) {
if (str->str_pok) {
- str_grow(str,growsize);
+ Str_Grow(str,growsize);
s = str_get(str) + j;
while (++j <= growsize) {
*s++ = '\0';
}
return sp;
}
+#endif /* SELECT */
+#ifdef SOCKET
int
do_spair(stab1, stab2, arglast)
STAB *stab1;
#ifdef I_PWD
register ARRAY *ary = stack;
register int sp = arglast[0];
- register char **elem;
register STR *str;
struct passwd *getpwnam();
struct passwd *getpwuid();
struct passwd *getpwent();
struct passwd *pwent;
- unsigned long len;
if (gimme != G_ARRAY) {
astore(ary, ++sp, str_static(&str_undef));
struct group *getgrgid();
struct group *getgrent();
struct group *grent;
- unsigned long len;
if (gimme != G_ARRAY) {
astore(ary, ++sp, str_static(&str_undef));
#endif
}
break;
+#if MACH
+ case O_TELLDIR:
+ case O_SEEKDIR:
+ goto nope;
+#else
case O_TELLDIR:
st[sp] = str_static(&str_undef);
str_numset(st[sp], (double)telldir(stio->dirp));
along = (long)str_gnum(st[sp+1]);
(void)seekdir(stio->dirp,along);
break;
+#endif
case O_REWINDDIR:
st[sp] = str_static(&str_undef);
(void)rewinddir(stio->dirp);
;# usage:
;#
;# #include <ctime.pl> # see the -P and -I option in perl.man
-;# $Date = do ctime(time);
+;# $Date = &ctime(time);
@DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
@MoY = ('Jan','Feb','Mar','Apr','May','Jun',
-#define PATCHLEVEL 20
+#define PATCHLEVEL 21
--- /dev/null
+/* $Header: curses.mus,v 3.0.1.1 90/08/09 04:05:21 lwall Locked $
+ *
+ * $Log: curses.mus,v $
+ * Revision 3.0.1.1 90/08/09 04:05:21 lwall
+ * patch19: Initial revision
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+extern int wantarray;
+
+char *savestr();
+
+#include <curses.h>
+
+static enum uservars {
+ UV_curscr,
+ UV_stdscr,
+ UV_Def_term,
+ UV_My_term,
+ UV_ttytype,
+ UV_LINES,
+ UV_COLS,
+ UV_ERR,
+ UV_OK,
+};
+
+static enum usersubs {
+ US_addch,
+ US_waddch,
+ US_addstr,
+ US_waddstr,
+ US_box,
+ US_clear,
+ US_wclear,
+ US_clearok,
+ US_clrtobot,
+ US_wclrtobot,
+ US_clrtoeol,
+ US_wclrtoeol,
+ US_delch,
+ US_wdelch,
+ US_deleteln,
+ US_wdeleteln,
+ US_erase,
+ US_werase,
+ US_flushok,
+ US_idlok,
+ US_insch,
+ US_winsch,
+ US_insertln,
+ US_winsertln,
+ US_move,
+ US_wmove,
+ US_overlay,
+ US_overwrite,
+ US_printw,
+ US_wprintw,
+ US_refresh,
+ US_wrefresh,
+ US_standout,
+ US_wstandout,
+ US_standend,
+ US_wstandend,
+ US_cbreak,
+ US_nocbreak,
+ US_echo,
+ US_noecho,
+ US_getch,
+ US_wgetch,
+ US_getstr,
+ US_wgetstr,
+ US_raw,
+ US_noraw,
+ US_scanw,
+ US_wscanw,
+ US_baudrate,
+ US_delwin,
+ US_endwin,
+ US_erasechar,
+ US_getcap,
+ US_getyx,
+ US_inch,
+ US_winch,
+ US_initscr,
+ US_killchar,
+ US_leaveok,
+ US_longname,
+ US_fullname,
+ US_mvwin,
+ US_newwin,
+ US_nl,
+ US_nonl,
+ US_scrollok,
+ US_subwin,
+ US_touchline,
+ US_touchoverlap,
+ US_touchwin,
+ US_unctrl,
+ US_gettmode,
+ US_mvcur,
+ US_scroll,
+ US_savetty,
+ US_resetty,
+ US_setterm,
+ US_tstp,
+ US__putchar,
+};
+
+static int usersub();
+static int userset();
+static int userval();
+
+int
+init_curses()
+{
+ struct ufuncs uf;
+ char *filename = "curses.c";
+
+ uf.uf_set = userset;
+ uf.uf_val = userval;
+
+#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
+
+ MAGICVAR("curscr", UV_curscr);
+ MAGICVAR("stdscr", UV_stdscr);
+ MAGICVAR("Def_term",UV_Def_term);
+ MAGICVAR("My_term", UV_My_term);
+ MAGICVAR("ttytype", UV_ttytype);
+ MAGICVAR("LINES", UV_LINES);
+ MAGICVAR("COLS", UV_COLS);
+ MAGICVAR("ERR", UV_ERR);
+ MAGICVAR("OK", UV_OK);
+
+ make_usub("addch", US_addch, usersub, filename);
+ make_usub("waddch", US_waddch, usersub, filename);
+ make_usub("addstr", US_addstr, usersub, filename);
+ make_usub("waddstr", US_waddstr, usersub, filename);
+ make_usub("box", US_box, usersub, filename);
+ make_usub("clear", US_clear, usersub, filename);
+ make_usub("wclear", US_wclear, usersub, filename);
+ make_usub("clearok", US_clearok, usersub, filename);
+ make_usub("clrtobot", US_clrtobot, usersub, filename);
+ make_usub("wclrtobot", US_wclrtobot, usersub, filename);
+ make_usub("clrtoeol", US_clrtoeol, usersub, filename);
+ make_usub("wclrtoeol", US_wclrtoeol, usersub, filename);
+ make_usub("delch", US_delch, usersub, filename);
+ make_usub("wdelch", US_wdelch, usersub, filename);
+ make_usub("deleteln", US_deleteln, usersub, filename);
+ make_usub("wdeleteln", US_wdeleteln, usersub, filename);
+ make_usub("erase", US_erase, usersub, filename);
+ make_usub("werase", US_werase, usersub, filename);
+ make_usub("flushok", US_flushok, usersub, filename);
+ make_usub("idlok", US_idlok, usersub, filename);
+ make_usub("insch", US_insch, usersub, filename);
+ make_usub("winsch", US_winsch, usersub, filename);
+ make_usub("insertln", US_insertln, usersub, filename);
+ make_usub("winsertln", US_winsertln, usersub, filename);
+ make_usub("move", US_move, usersub, filename);
+ make_usub("wmove", US_wmove, usersub, filename);
+ make_usub("overlay", US_overlay, usersub, filename);
+ make_usub("overwrite", US_overwrite, usersub, filename);
+ make_usub("printw", US_printw, usersub, filename);
+ make_usub("wprintw", US_wprintw, usersub, filename);
+ make_usub("refresh", US_refresh, usersub, filename);
+ make_usub("wrefresh", US_wrefresh, usersub, filename);
+ make_usub("standout", US_standout, usersub, filename);
+ make_usub("wstandout", US_wstandout, usersub, filename);
+ make_usub("standend", US_standend, usersub, filename);
+ make_usub("wstandend", US_wstandend, usersub, filename);
+ make_usub("cbreak", US_cbreak, usersub, filename);
+ make_usub("nocbreak", US_nocbreak, usersub, filename);
+ make_usub("echo", US_echo, usersub, filename);
+ make_usub("noecho", US_noecho, usersub, filename);
+ make_usub("getch", US_getch, usersub, filename);
+ make_usub("wgetch", US_wgetch, usersub, filename);
+ make_usub("getstr", US_getstr, usersub, filename);
+ make_usub("wgetstr", US_wgetstr, usersub, filename);
+ make_usub("raw", US_raw, usersub, filename);
+ make_usub("noraw", US_noraw, usersub, filename);
+ make_usub("scanw", US_scanw, usersub, filename);
+ make_usub("wscanw", US_wscanw, usersub, filename);
+ make_usub("baudrate", US_baudrate, usersub, filename);
+ make_usub("delwin", US_delwin, usersub, filename);
+ make_usub("endwin", US_endwin, usersub, filename);
+ make_usub("erasechar", US_erasechar, usersub, filename);
+ make_usub("getcap", US_getcap, usersub, filename);
+ make_usub("getyx", US_getyx, usersub, filename);
+ make_usub("inch", US_inch, usersub, filename);
+ make_usub("winch", US_winch, usersub, filename);
+ make_usub("initscr", US_initscr, usersub, filename);
+ make_usub("killchar", US_killchar, usersub, filename);
+ make_usub("leaveok", US_leaveok, usersub, filename);
+ make_usub("longname", US_longname, usersub, filename);
+ make_usub("fullname", US_fullname, usersub, filename);
+ make_usub("mvwin", US_mvwin, usersub, filename);
+ make_usub("newwin", US_newwin, usersub, filename);
+ make_usub("nl", US_nl, usersub, filename);
+ make_usub("nonl", US_nonl, usersub, filename);
+ make_usub("scrollok", US_scrollok, usersub, filename);
+ make_usub("subwin", US_subwin, usersub, filename);
+ make_usub("touchline", US_touchline, usersub, filename);
+ make_usub("touchoverlap", US_touchoverlap,usersub, filename);
+ make_usub("touchwin", US_touchwin, usersub, filename);
+ make_usub("unctrl", US_unctrl, usersub, filename);
+ make_usub("gettmode", US_gettmode, usersub, filename);
+ make_usub("mvcur", US_mvcur, usersub, filename);
+ make_usub("scroll", US_scroll, usersub, filename);
+ make_usub("savetty", US_savetty, usersub, filename);
+ make_usub("resetty", US_resetty, usersub, filename);
+ make_usub("setterm", US_setterm, usersub, filename);
+ make_usub("tstp", US_tstp, usersub, filename);
+ make_usub("_putchar", US__putchar, usersub, filename);
+};
+
+static int
+usersub(ix, sp, items)
+int ix;
+register int sp;
+register int items;
+{
+ STR **st = stack->ary_array + sp;
+ register int i;
+ register char *tmps;
+ register STR *Str; /* used in str_get and str_gnum macros */
+
+ switch (ix) {
+CASE int addch
+I char ch
+END
+
+CASE int waddch
+I WINDOW* win
+I char ch
+END
+
+CASE int addstr
+I char* str
+END
+
+CASE int waddstr
+I WINDOW* win
+I char* str
+END
+
+CASE int box
+I WINDOW* win
+I char vert
+I char hor
+END
+
+CASE int clear
+END
+
+CASE int wclear
+I WINDOW* win
+END
+
+CASE int clearok
+I WINDOW* win
+I bool boolf
+END
+
+CASE int clrtobot
+END
+
+CASE int wclrtobot
+I WINDOW* win
+END
+
+CASE int clrtoeol
+END
+
+CASE int wclrtoeol
+I WINDOW* win
+END
+
+CASE int delch
+END
+
+CASE int wdelch
+I WINDOW* win
+END
+
+CASE int deleteln
+END
+
+CASE int wdeleteln
+I WINDOW* win
+END
+
+CASE int erase
+END
+
+CASE int werase
+I WINDOW* win
+END
+
+CASE int flushok
+I WINDOW* win
+I bool boolf
+END
+
+CASE int idlok
+I WINDOW* win
+I bool boolf
+END
+
+CASE int insch
+I char c
+END
+
+CASE int winsch
+I WINDOW* win
+I char c
+END
+
+CASE int insertln
+END
+
+CASE int winsertln
+I WINDOW* win
+END
+
+CASE int move
+I int y
+I int x
+END
+
+CASE int wmove
+I WINDOW* win
+I int y
+I int x
+END
+
+CASE int overlay
+I WINDOW* win1
+I WINDOW* win2
+END
+
+CASE int overwrite
+I WINDOW* win1
+I WINDOW* win2
+END
+
+ case US_printw:
+ if (items < 1)
+ fatal("Usage: &printw($fmt, $arg1, $arg2, ... )");
+ else {
+ int retval;
+ STR* str = str_new(0);
+
+ do_sprintf(str, items - 1, st + 1);
+ retval = addstr(str->str_ptr);
+ str_numset(st[0], (double) retval);
+ str_free(str);
+ }
+ return sp;
+
+ case US_wprintw:
+ if (items < 2)
+ fatal("Usage: &wprintw($win, $fmt, $arg1, $arg2, ... )");
+ else {
+ int retval;
+ STR* str = str_new(0);
+ WINDOW* win = *(WINDOW**) str_get(st[1]);
+
+ do_sprintf(str, items - 1, st + 1);
+ retval = waddstr(win, str->str_ptr);
+ str_numset(st[0], (double) retval);
+ str_free(str);
+ }
+ return sp;
+
+CASE int refresh
+END
+
+CASE int wrefresh
+I WINDOW* win
+END
+
+CASE int standout
+END
+
+CASE int wstandout
+I WINDOW* win
+END
+
+CASE int standend
+END
+
+CASE int wstandend
+I WINDOW* win
+END
+
+CASE int cbreak
+END
+
+CASE int nocbreak
+END
+
+CASE int echo
+END
+
+CASE int noecho
+END
+
+ case US_getch:
+ if (items != 0)
+ fatal("Usage: &getch()");
+ else {
+ int retval;
+ char retch;
+
+ retval = getch();
+ if (retval == EOF)
+ st[0] = &str_undef;
+ else {
+ retch = retval;
+ str_nset(st[0], &retch, 1);
+ }
+ }
+ return sp;
+
+ case US_wgetch:
+ if (items != 1)
+ fatal("Usage: &wgetch($win)");
+ else {
+ int retval;
+ char retch;
+ WINDOW* win = *(WINDOW**) str_get(st[1]);
+
+ retval = wgetch(win);
+ if (retval == EOF)
+ st[0] = &str_undef;
+ else {
+ retch = retval;
+ str_nset(st[0], &retch, 1);
+ }
+ }
+ return sp;
+
+CASE int getstr
+IO char* str
+END
+
+CASE int wgetstr
+I WINDOW* win
+IO char* str
+END
+
+CASE int raw
+END
+
+CASE int noraw
+END
+
+CASE int baudrate
+END
+
+CASE int delwin
+I WINDOW* win
+END
+
+CASE int endwin
+END
+
+CASE int erasechar
+END
+
+CASE char* getcap
+I char* str
+END
+
+ case US_getyx:
+ if (items != 3)
+ fatal("Usage: &getyx($win, $y, $x)");
+ else {
+ int retval;
+ STR* str = str_new(0);
+ WINDOW* win = *(WINDOW**) str_get(st[1]);
+ int y;
+ int x;
+
+ do_sprintf(str, items - 1, st + 1);
+ retval = getyx(win, y, x);
+ str_numset(st[2], (double)y);
+ str_numset(st[3], (double)x);
+ str_numset(st[0], (double) retval);
+ str_free(str);
+ }
+ return sp;
+
+
+CASE int inch
+END
+
+CASE int winch
+I WINDOW* win
+END
+
+CASE WINDOW* initscr
+END
+
+CASE int killchar
+END
+
+CASE int leaveok
+I WINDOW* win
+I bool boolf
+END
+
+CASE char* longname
+I char* termbuf
+IO char* name
+END
+
+CASE int fullname
+I char* termbuf
+IO char* name
+END
+
+CASE int mvwin
+I WINDOW* win
+I int y
+I int x
+END
+
+CASE WINDOW* newwin
+I int lines
+I int cols
+I int begin_y
+I int begin_x
+END
+
+CASE int nl
+END
+
+CASE int nonl
+END
+
+CASE int scrollok
+I WINDOW* win
+I bool boolf
+END
+
+CASE WINDOW* subwin
+I WINDOW* win
+I int lines
+I int cols
+I int begin_y
+I int begin_x
+END
+
+CASE int touchline
+I WINDOW* win
+I int y
+I int startx
+I int endx
+END
+
+CASE int touchoverlap
+I WINDOW* win1
+I WINDOW* win2
+END
+
+CASE int touchwin
+I WINDOW* win
+END
+
+CASE char* unctrl
+I char ch
+END
+
+CASE int gettmode
+END
+
+CASE int mvcur
+I int lasty
+I int lastx
+I int newy
+I int newx
+END
+
+CASE int scroll
+I WINDOW* win
+END
+
+CASE int savetty
+END
+
+CASE void resetty
+END
+
+CASE int setterm
+I char* name
+END
+
+CASE int tstp
+END
+
+CASE int _putchar
+I char ch
+END
+
+ default:
+ fatal("Unimplemented user-defined subroutine");
+ }
+ return sp;
+}
+
+static int
+userval(ix, str)
+int ix;
+STR *str;
+{
+ switch (ix) {
+ case UV_COLS:
+ str_numset(str, (double)COLS);
+ break;
+ case UV_Def_term:
+ str_set(str, Def_term);
+ break;
+ case UV_ERR:
+ str_numset(str, (double)ERR);
+ break;
+ case UV_LINES:
+ str_numset(str, (double)LINES);
+ break;
+ case UV_My_term:
+ str_numset(str, (double)My_term);
+ break;
+ case UV_OK:
+ str_numset(str, (double)OK);
+ break;
+ case UV_curscr:
+ str_nset(str, &curscr, sizeof(WINDOW*));
+ break;
+ case UV_stdscr:
+ str_nset(str, &stdscr, sizeof(WINDOW*));
+ break;
+ case UV_ttytype:
+ str_set(str, ttytype);
+ break;
+ }
+ return 0;
+}
+
+static int
+userset(ix, str)
+int ix;
+STR *str;
+{
+ switch (ix) {
+ case UV_COLS:
+ COLS = (int)str_gnum(str);
+ break;
+ case UV_Def_term:
+ Def_term = savestr(str_get(str)); /* never freed */
+ break;
+ case UV_LINES:
+ LINES = (int)str_gnum(str);
+ break;
+ case UV_My_term:
+ My_term = (bool)str_gnum(str);
+ break;
+ case UV_ttytype:
+ strcpy(ttytype, str_get(str)); /* hope it fits */
+ break;
+ }
+ return 0;
+}
projects / platform / upstream / perl.git / commitdiff