1 char rcsid[] = "$Header: perly.c,v 2.0.1.1 88/06/28 16:36:49 root Exp $";
4 * Revision 2.0.1.1 88/06/28 16:36:49 root
5 * patch1: added DOSUID code
7 * Revision 2.0 88/06/05 00:09:56 root
8 * Baseline version 2.0.
16 extern char *tokename[];
19 static int cmd_tosave();
20 static int arg_tosave();
21 static int spat_tosave();
30 char *index(), *strcpy(), *getenv();
31 bool dosearch = FALSE;
33 char **origargv = argv;
38 euid = (int)geteuid();
39 linestr = str_new(80);
40 str_nset(linestr,"",0);
41 str = str_make(""); /* first used for -I flags */
42 incstab = aadd(stabent("INC",TRUE));
43 for (argc--,argv++; argc; argc--,argv++) {
44 if (argv[0][0] != '-' || !argv[0][1])
48 validarg = " PHOOEY ";
63 yydebug = (debug & 1);
69 e_tmpname = strcpy(safemalloc(sizeof(TMPPATH)),TMPPATH);
71 e_fp = fopen(e_tmpname,"w");
79 inplace = savestr(s+1);
80 argvoutstab = stabent("ARGVOUT",TRUE);
87 apush(incstab->stab_array,str_make(s+1));
90 apush(incstab->stab_array,str_make(argv[1]));
133 fatal("Unrecognized switch: -%s",s);
143 #define PRIVLIB "/usr/local/lib/perl"
145 apush(incstab->stab_array,str_make(PRIVLIB));
148 str_set(&str_yes,Yes);
153 if (argv[0] == Nullch)
155 if (dosearch && argv[0][0] != '/' && (s = getenv("PATH"))) {
156 char *xfound = Nullch, *xfailed = Nullch;
159 s = cpytill(tokenbuf,s,':');
163 strcat(tokenbuf,"/");
164 strcat(tokenbuf,argv[0]);
167 fprintf(stderr,"Looking for %s\n",tokenbuf);
169 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
171 if ((statbuf.st_mode & S_IFMT) == S_IFREG
172 && cando(S_IREAD,TRUE) && cando(S_IEXEC,TRUE)) {
173 xfound = tokenbuf; /* bingo! */
177 xfailed = savestr(tokenbuf);
180 fatal("Can't execute %s", xfailed);
183 argv[0] = savestr(xfound);
185 filename = savestr(argv[0]);
186 origfilename = savestr(filename);
187 if (strEQ(filename,"-"))
191 str_cat(str,PRIVLIB);
193 /bin/sed -e '/^[^#]/b' \
194 -e '/^#[ ]*include[ ]/b' \
195 -e '/^#[ ]*define[ ]/b' \
196 -e '/^#[ ]*if[ ]/b' \
197 -e '/^#[ ]*ifdef[ ]/b' \
198 -e '/^#[ ]*ifndef[ ]/b' \
200 -e '/^#[ ]*endif/b' \
203 argv[0], CPPSTDIN, str_get(str), CPPMINUS);
205 if (euid != uid && !euid) /* if running suidperl */
206 seteuid(uid); /* musn't stay setuid root */
208 rsfp = popen(buf,"r");
213 rsfp = fopen(argv[0],"r");
214 if (rsfp == Nullfp) {
217 if (euid && stat(filename,&statbuf) >= 0 &&
218 statbuf.st_mode & (S_ISUID|S_ISGID)) {
219 execvp("suidperl", origargv); /* try again */
220 fatal("Can't do setuid\n");
224 fatal("Perl script \"%s\" doesn't seem to exist",filename);
226 str_free(str); /* free -I directories */
228 /* do we need to emulate setuid on scripts? */
230 /* This code is for those BSD systems that have setuid #! scripts disabled
231 * in the kernel because of a security problem. Merely defining DOSUID
232 * in perl will not fix that problem, but if you have disabled setuid
233 * scripts in the kernel, this will attempt to emulate setuid and setgid
234 * on scripts that have those now-otherwise-useless bits set. The setuid
235 * root version must be called suidperl. If regular perl discovers that
236 * it has opened a setuid script, it calls suidperl with the same argv
237 * that it had. If suidperl finds that the script it has just opened
238 * is NOT setuid root, it sets the effective uid back to the uid. We
239 * don't just make perl setuid root because that loses the effective
240 * uid we had before invoking perl, if it was different from the uid.
242 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
243 * be defined in suidperl only. suidperl must be setuid root. The
244 * Configure script will set this up for you if you want it.
247 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
248 fatal("Can't stat script \"%s\"",filename);
249 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
252 if (access(filename,1)) /* as a double check */
253 fatal("Permission denied");
254 if ((statbuf.st_mode & S_IFMT) != S_IFREG)
255 fatal("Permission denied");
256 doswitches = FALSE; /* -s is insecure in suid */
258 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
259 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
261 for (s = tokenbuf+2; !isspace(*s); s++) ;
262 if (strnNE(s-4,"perl",4)) /* sanity check */
263 fatal("Not a perl script");
264 while (*s && isspace(*s)) s++;
266 * #! arg must be what we saw above. They can invoke it by
267 * mentioning suidperl explicitly, but they may not add any strange
268 * arguments beyond what #! says if they do invoke suidperl that way.
270 len = strlen(validarg);
271 if (strEQ(validarg," PHOOEY ") ||
272 strnNE(s,validarg,len) || !isspace(s[len]))
273 fatal("Arg must be \"%s\"\n",s);
275 if (euid) { /* oops, we're not the setuid root perl */
278 execvp("suidperl", origargv); /* try again */
280 fatal("Can't do setuid\n");
283 if (statbuf.st_mode & S_ISUID && statbuf.st_uid != euid)
284 seteuid(statbuf.st_uid); /* all that for this */
285 else if (uid) /* oops, mustn't run as root */
287 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
288 setegid(statbuf.st_gid);
289 euid = (int)geteuid();
290 if (!cando(S_IEXEC,TRUE))
291 fatal("Permission denied\n"); /* they can't do this */
295 fatal("-P not allowed for setuid/setgid script\n");
297 fatal("Script is not setuid/setgid in suidperl\n");
301 defstab = stabent("_",TRUE);
305 bufptr = str_get(linestr);
307 /* now parse the report spec */
310 fatal("Execution aborted due to compilation errors.\n");
322 argc--,argv++; /* skip name of script */
324 for (; argc > 0 && **argv == '-'; argc--,argv++) {
325 if (argv[0][1] == '-') {
329 str_numset(stabent(argv[0]+1,TRUE)->stab_val,(double)1.0);
332 if (argvstab = stabent("ARGV",allstabs)) {
334 for (; argc > 0; argc--,argv++) {
335 apush(argvstab->stab_array,str_make(argv[0]));
338 if (envstab = stabent("ENV",allstabs)) {
340 for (; *env; env++) {
341 if (!(s = index(*env,'=')))
345 str->str_link.str_magic = envstab;
346 hstore(envstab->stab_hash,*env,str);
350 if (sigstab = stabent("SIG",allstabs))
353 magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|");
355 sawampersand = (stabent("&",FALSE) != Nullstab);
356 if (tmpstab = stabent("0",allstabs))
357 str_set(STAB_STR(tmpstab),origfilename);
358 if (tmpstab = stabent("$",allstabs))
359 str_numset(STAB_STR(tmpstab),(double)getpid());
361 tmpstab = stabent("stdin",TRUE);
362 tmpstab->stab_io = stio_new();
363 tmpstab->stab_io->fp = stdin;
365 tmpstab = stabent("stdout",TRUE);
366 tmpstab->stab_io = stio_new();
367 tmpstab->stab_io->fp = stdout;
368 defoutstab = tmpstab;
369 curoutstab = tmpstab;
371 tmpstab = stabent("stderr",TRUE);
372 tmpstab->stab_io = stio_new();
373 tmpstab->stab_io->fp = stderr;
375 savestack = anew(Nullstab); /* for saving non-local values */
377 setjmp(top_env); /* sets goto_targ on longjump */
381 dump_cmd(main_root,Nullcmd);
383 fprintf(stderr,"\nEXECUTING...\n\n");
388 (void) cmd_exec(main_root);
391 fatal("Can't find label \"%s\"--aborting",goto_targ);
403 while (*sym = *list++) {
404 if (stab = stabent(sym,allstabs)) {
405 stab->stab_flags = SF_VMAGIC;
406 stab->stab_val->str_link.str_magic = stab;
416 register SPAT *spat = (SPAT *) safemalloc(sizeof (SPAT));
418 if (arg->arg_type != O_MATCH) {
419 spat = (SPAT *) safemalloc(sizeof (SPAT));
420 bzero((char *)spat, sizeof(SPAT));
421 spat->spat_next = spat_root; /* link into spat list */
424 spat->spat_runtime = arg;
425 arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
427 arg->arg_type = O_SPLIT;
428 spat = arg[2].arg_ptr.arg_spat;
429 spat->spat_repl = stab2arg(A_STAB,aadd(stab));
430 if (spat->spat_short) { /* exact match can bypass regexec() */
431 if (!((spat->spat_flags & SPAT_SCANFIRST) &&
432 (spat->spat_flags & SPAT_ALL) )) {
433 str_free(spat->spat_short);
434 spat->spat_short = Nullstr;
445 register SUBR *sub = (SUBR *) safemalloc(sizeof (SUBR));
446 STAB *stab = stabent(name,TRUE);
448 if (stab->stab_sub) {
450 line_t oldline = line;
454 warn("Subroutine %s redefined",name);
457 cmd_free(stab->stab_sub->cmd);
458 afree(stab->stab_sub->tosave);
459 safefree((char*)stab->stab_sub);
461 bzero((char *)sub, sizeof(SUBR));
463 sub->filename = filename;
464 tosave = anew(Nullstab);
465 tosave->ary_fill = 0; /* make 1 based */
466 cmd_tosave(cmd); /* this builds the tosave array */
467 sub->tosave = tosave;
468 stab->stab_sub = sub;
475 if (tail == Nullcmd) {
482 append_line(head,tail)
488 if (!tail->c_head) /* make sure tail is well formed */
490 if (head != Nullcmd) {
491 tail = tail->c_head; /* get to start of tail list */
493 head->c_head = head; /* start a new head list */
494 while (head->c_next) {
495 head->c_next->c_head = head->c_head;
496 head = head->c_next; /* get to end of head list */
498 head->c_next = tail; /* link to end of old list */
499 tail->c_head = head->c_head; /* propagate head pointer */
501 while (tail->c_next) {
502 tail->c_next->c_head = tail->c_head;
509 make_acmd(type,stab,cond,arg)
515 register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
517 bzero((char *)cmd, sizeof(CMD));
519 cmd->ucmd.acmd.ac_stab = stab;
520 cmd->ucmd.acmd.ac_expr = arg;
524 cmd->c_flags |= CF_COND;
526 if (cmdline != NOLINE) {
527 cmd->c_line = cmdline;
530 cmd->c_file = filename;
535 make_ccmd(type,arg,cblock)
538 struct compcmd cblock;
540 register CMD *cmd = (CMD *) safemalloc(sizeof (CMD));
542 bzero((char *)cmd, sizeof(CMD));
545 cmd->ucmd.ccmd.cc_true = cblock.comp_true;
546 cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
549 cmd->c_flags |= CF_COND;
551 if (cmdline != NOLINE) {
552 cmd->c_line = cmdline;
559 opt_arg(cmd,fliporflop,acmd)
568 char *tmps; /* for True macro */
569 int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */
570 int flp = fliporflop;
576 /* Can we turn && and || into if and unless? */
578 if (acmd && !cmd->ucmd.acmd.ac_expr &&
579 (arg->arg_type == O_AND || arg->arg_type == O_OR) ) {
582 cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg;
583 cmd->c_expr = arg[1].arg_ptr.arg_arg;
584 if (arg->arg_type == O_OR)
585 cmd->c_flags ^= CF_INVERT; /* || is like unless */
591 /* Turn "if (!expr)" into "unless (expr)" */
593 while (arg->arg_type == O_NOT) {
595 cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */
596 cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */
598 arg = cmd->c_expr; /* here we go again */
601 if (!arg->arg_len) { /* sanity check */
606 /* for "cond .. cond" we set up for the initial check */
608 if (arg->arg_type == O_FLIP)
611 /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */
613 if (arg->arg_type == O_AND)
615 else if (arg->arg_type == O_OR)
617 if (context && arg[flp].arg_type == A_EXPR) {
618 arg = arg[flp].arg_ptr.arg_arg;
622 if (arg[flp].arg_flags & (AF_PRE|AF_POST)) {
624 return; /* side effect, can't optimize */
627 if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP ||
628 arg->arg_type == O_AND || arg->arg_type == O_OR) {
629 if (arg[flp].arg_type == A_SINGLE) {
630 opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE);
631 cmd->c_short = arg[flp].arg_ptr.arg_str;
634 else if (arg[flp].arg_type == A_STAB || arg[flp].arg_type == A_LVAL) {
635 cmd->c_stab = arg[flp].arg_ptr.arg_stab;
638 if (!context) { /* no && or ||? */
640 cmd->c_expr = Nullarg;
643 cmd->c_flags |= CF_EQSURE;
645 cmd->c_flags |= CF_NESURE;
648 else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST ||
649 arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) {
650 if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
651 arg[2].arg_type == A_SPAT &&
652 arg[2].arg_ptr.arg_spat->spat_short ) {
653 cmd->c_stab = arg[1].arg_ptr.arg_stab;
654 cmd->c_short = arg[2].arg_ptr.arg_spat->spat_short;
655 cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen;
656 if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL &&
657 !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) &&
658 (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) )
659 sure |= CF_EQSURE; /* (SUBST must be forced even */
660 /* if we know it will work.) */
661 arg[2].arg_ptr.arg_spat->spat_short = Nullstr;
662 arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */
663 sure |= CF_NESURE; /* normally only sure if it fails */
664 if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST)
665 cmd->c_flags |= CF_FIRSTNEG;
666 if (context & 1) { /* only sure if thing is false */
667 if (cmd->c_flags & CF_FIRSTNEG)
672 else if (context & 2) { /* only sure if thing is true */
673 if (cmd->c_flags & CF_FIRSTNEG)
678 if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/
679 if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST)
683 if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */
684 && arg->arg_type == O_MATCH
686 && fliporflop == 1) {
687 spat_free(arg[2].arg_ptr.arg_spat);
688 arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */
690 cmd->c_flags |= sure;
694 else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE ||
695 arg->arg_type == O_SLT || arg->arg_type == O_SGT) {
696 if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
697 if (arg[2].arg_type == A_SINGLE) {
698 cmd->c_stab = arg[1].arg_ptr.arg_stab;
699 cmd->c_short = arg[2].arg_ptr.arg_str;
701 switch (arg->arg_type) {
702 case O_SLT: case O_SGT:
704 cmd->c_flags |= CF_FIRSTNEG;
707 cmd->c_flags |= CF_FIRSTNEG;
710 sure |= CF_NESURE|CF_EQSURE;
713 if (context & 1) { /* only sure if thing is false */
714 if (cmd->c_flags & CF_FIRSTNEG)
719 else if (context & 2) { /* only sure if thing is true */
720 if (cmd->c_flags & CF_FIRSTNEG)
725 if (sure & (CF_EQSURE|CF_NESURE)) {
727 cmd->c_flags |= sure;
732 else if (arg->arg_type == O_EQ || arg->arg_type == O_NE ||
733 arg->arg_type == O_LE || arg->arg_type == O_GE ||
734 arg->arg_type == O_LT || arg->arg_type == O_GT) {
735 if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) {
736 if (arg[2].arg_type == A_SINGLE) {
737 cmd->c_stab = arg[1].arg_ptr.arg_stab;
738 cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str));
739 cmd->c_slen = arg->arg_type;
740 sure |= CF_NESURE|CF_EQSURE;
741 if (context & 1) { /* only sure if thing is false */
744 else if (context & 2) { /* only sure if thing is true */
747 if (sure & (CF_EQSURE|CF_NESURE)) {
749 cmd->c_flags |= sure;
754 else if (arg->arg_type == O_ASSIGN &&
755 (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) &&
756 arg[1].arg_ptr.arg_stab == defstab &&
757 arg[2].arg_type == A_EXPR ) {
758 arg2 = arg[2].arg_ptr.arg_arg;
759 if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) {
761 cmd->c_stab = arg2[1].arg_ptr.arg_stab;
762 if (!(arg2[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV)) {
765 cmd->c_expr = Nullarg;
769 else if (arg->arg_type == O_CHOP &&
770 (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) {
772 cmd->c_stab = arg[1].arg_ptr.arg_stab;
774 cmd->c_expr = Nullarg;
780 if (cmd->c_flags & CF_FLIP) {
781 if (fliporflop == 1) {
782 arg = cmd->c_expr; /* get back to O_FLIP arg */
783 arg[3].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
784 bcopy((char *)cmd, (char *)arg[3].arg_ptr.arg_cmd, sizeof(CMD));
785 arg[4].arg_ptr.arg_cmd = (CMD*)safemalloc(sizeof(CMD));
786 bcopy((char *)cmd, (char *)arg[4].arg_ptr.arg_cmd, sizeof(CMD));
787 opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd);
788 arg->arg_len = 2; /* this is a lie */
791 if ((opt & CF_OPTIMIZE) == CFT_EVAL)
792 cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP;
798 mod_match(type,left,pat)
804 register ARG *newarg;
806 if ((pat->arg_type == O_MATCH ||
807 pat->arg_type == O_SUBST ||
808 pat->arg_type == O_TRANS ||
809 pat->arg_type == O_SPLIT
811 pat[1].arg_ptr.arg_stab == defstab ) {
812 switch (pat->arg_type) {
814 newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH,
816 left,Nullarg,Nullarg,0);
819 newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST,
821 left,Nullarg,Nullarg,0));
824 newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS,
826 left,Nullarg,Nullarg,0));
829 newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT,
831 left,Nullarg,Nullarg,0);
834 if (pat->arg_len >= 2) {
835 newarg[2].arg_type = pat[2].arg_type;
836 newarg[2].arg_ptr = pat[2].arg_ptr;
837 newarg[2].arg_flags = pat[2].arg_flags;
838 if (pat->arg_len >= 3) {
839 newarg[3].arg_type = pat[3].arg_type;
840 newarg[3].arg_ptr = pat[3].arg_ptr;
841 newarg[3].arg_flags = pat[3].arg_flags;
844 safefree((char*)pat);
847 spat = (SPAT *) safemalloc(sizeof (SPAT));
848 bzero((char *)spat, sizeof(SPAT));
849 spat->spat_next = spat_root; /* link into spat list */
852 spat->spat_runtime = pat;
853 newarg = make_op(type,2,left,Nullarg,Nullarg,0);
854 newarg[2].arg_type = A_SPAT;
855 newarg[2].arg_ptr.arg_spat = spat;
856 newarg[2].arg_flags = AF_SPECIAL;
879 cmd->c_flags |= CF_COND;
890 cmd->c_flags |= CF_COND|CF_LOOP;
891 if (cmd->c_type == C_BLOCK)
892 cmd->c_flags &= ~CF_COND;
894 arg = cmd->ucmd.acmd.ac_expr;
895 if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD)
896 cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */
897 if (arg && arg->arg_type == O_SUBR)
898 cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */
907 cmd->c_flags ^= CF_INVERT;
915 char *tname = tmpbuf;
918 tname = tokename[yychar-256];
919 if (strEQ(tname,"word"))
920 strcpy(tname,tokenbuf);
921 else if (strEQ(tname,"register"))
922 sprintf(tname,"$%s",tokenbuf);
923 else if (strEQ(tname,"array_length"))
924 sprintf(tname,"$#%s",tokenbuf);
928 else if (yychar < 32)
929 sprintf(tname,"^%c",yychar+64);
930 else if (yychar == 127)
933 sprintf(tname,"%c",yychar);
934 sprintf(tokenbuf, "%s in file %s at line %d, next token \"%s\"\n",
935 s,filename,line,tname);
937 str_set(stabent("@",TRUE)->stab_val,tokenbuf);
939 fputs(tokenbuf,stderr);
943 make_op(type,newlen,arg1,arg2,arg3,dolist)
955 arg = op_new(newlen);
956 arg->arg_type = type;
957 doarg = opargs[type];
960 arg[1].arg_flags |= AF_SPECIAL;
962 arg[1].arg_flags |= AF_NUMERIC;
963 if (chld->arg_type == O_ITEM &&
964 (hoistable[chld[1].arg_type] || chld[1].arg_type == A_LVAL) ) {
965 arg[1].arg_type = chld[1].arg_type;
966 arg[1].arg_ptr = chld[1].arg_ptr;
967 arg[1].arg_flags |= chld[1].arg_flags;
971 arg[1].arg_type = A_EXPR;
972 arg[1].arg_ptr.arg_arg = chld;
974 if (chld->arg_type == O_LIST) {
975 if (newlen == 1) { /* we can hoist entire list */
976 chld->arg_type = type;
981 arg[1].arg_flags |= AF_SPECIAL;
985 switch (chld->arg_type) {
987 if (chld->arg_len == 1)
988 arg[1].arg_flags |= AF_SPECIAL;
991 if (chld[1].arg_type == A_READ ||
992 chld[1].arg_type == A_INDREAD ||
993 chld[1].arg_type == A_GLOB)
994 arg[1].arg_flags |= AF_SPECIAL;
1002 arg[1].arg_flags |= AF_SPECIAL;
1011 arg[2].arg_flags |= AF_SPECIAL;
1013 arg[2].arg_flags |= AF_NUMERIC;
1014 if (chld->arg_type == O_ITEM &&
1015 (hoistable[chld[1].arg_type] ||
1016 (type == O_ASSIGN &&
1017 ((chld[1].arg_type == A_READ && !(arg[1].arg_flags & AF_SPECIAL))
1019 (chld[1].arg_type == A_INDREAD && !(arg[1].arg_flags & AF_SPECIAL))
1021 (chld[1].arg_type == A_GLOB && !(arg[1].arg_flags & AF_SPECIAL))
1023 chld[1].arg_type == A_BACKTICK ) ) ) ) {
1024 arg[2].arg_type = chld[1].arg_type;
1025 arg[2].arg_ptr = chld[1].arg_ptr;
1029 arg[2].arg_type = A_EXPR;
1030 arg[2].arg_ptr.arg_arg = chld;
1032 (chld->arg_type == O_LIST ||
1033 (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
1034 arg[2].arg_flags |= AF_SPECIAL;
1039 arg[3].arg_flags |= AF_SPECIAL;
1041 arg[3].arg_flags |= AF_NUMERIC;
1042 if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type]) {
1043 arg[3].arg_type = chld[1].arg_type;
1044 arg[3].arg_ptr = chld[1].arg_ptr;
1048 arg[3].arg_type = A_EXPR;
1049 arg[3].arg_ptr.arg_arg = chld;
1051 (chld->arg_type == O_LIST ||
1052 (chld->arg_type == O_ARRAY && chld->arg_len == 1) ))
1053 arg[3].arg_flags |= AF_SPECIAL;
1058 fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]);
1060 fprintf(stderr,",%s=%lx",
1061 argname[arg[1].arg_type],arg[1].arg_ptr.arg_arg);
1063 fprintf(stderr,",%s=%lx",
1064 argname[arg[2].arg_type],arg[2].arg_ptr.arg_arg);
1066 fprintf(stderr,",%s=%lx",
1067 argname[arg[3].arg_type],arg[3].arg_ptr.arg_arg);
1068 fprintf(stderr,")\n");
1071 evalstatic(arg); /* see if we can consolidate anything */
1075 /* turn 123 into 123 == $. */
1081 if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_SINGLE) {
1082 arg = (ARG*)saferealloc((char*)arg,3*sizeof(ARG));
1083 arg->arg_type = O_EQ;
1085 arg[2].arg_type = A_STAB;
1086 arg[2].arg_flags = 0;
1087 arg[2].arg_ptr.arg_stab = stabent(".",TRUE);
1099 double value; /* must not be register */
1100 register char *tmps;
1102 unsigned long tmplong;
1103 double exp(), log(), sqrt(), modf();
1106 if (!arg || !arg->arg_len)
1109 if (arg[1].arg_type == A_SINGLE &&
1110 (arg->arg_len == 1 || arg[2].arg_type == A_SINGLE) ) {
1112 s1 = arg[1].arg_ptr.arg_str;
1113 if (arg->arg_len > 1)
1114 s2 = arg[2].arg_ptr.arg_str;
1117 switch (arg->arg_type) {
1120 str = Nullstr; /* can't be evaluated yet */
1127 i = (int)str_gnum(s2);
1132 value = str_gnum(s1);
1133 str_numset(str,value * str_gnum(s2));
1136 value = str_gnum(s2);
1138 fatal("Illegal division by constant zero");
1139 str_numset(str,str_gnum(s1) / value);
1142 tmplong = (unsigned long)str_gnum(s2);
1144 fatal("Illegal modulus of constant zero");
1145 str_numset(str,(double)(((unsigned long)str_gnum(s1)) % tmplong));
1148 value = str_gnum(s1);
1149 str_numset(str,value + str_gnum(s2));
1152 value = str_gnum(s1);
1153 str_numset(str,value - str_gnum(s2));
1156 value = str_gnum(s1);
1157 i = (int)str_gnum(s2);
1158 str_numset(str,(double)(((unsigned long)value) << i));
1161 value = str_gnum(s1);
1162 i = (int)str_gnum(s2);
1163 str_numset(str,(double)(((unsigned long)value) >> i));
1166 value = str_gnum(s1);
1167 str_numset(str,(double)(value < str_gnum(s2)));
1170 value = str_gnum(s1);
1171 str_numset(str,(double)(value > str_gnum(s2)));
1174 value = str_gnum(s1);
1175 str_numset(str,(double)(value <= str_gnum(s2)));
1178 value = str_gnum(s1);
1179 str_numset(str,(double)(value >= str_gnum(s2)));
1182 value = str_gnum(s1);
1183 str_numset(str,(double)(value == str_gnum(s2)));
1186 value = str_gnum(s1);
1187 str_numset(str,(double)(value != str_gnum(s2)));
1190 value = str_gnum(s1);
1191 str_numset(str,(double)(((unsigned long)value) &
1192 ((unsigned long)str_gnum(s2))));
1195 value = str_gnum(s1);
1196 str_numset(str,(double)(((unsigned long)value) ^
1197 ((unsigned long)str_gnum(s2))));
1200 value = str_gnum(s1);
1201 str_numset(str,(double)(((unsigned long)value) |
1202 ((unsigned long)str_gnum(s2))));
1206 str = str_make(str_get(s2));
1208 str = str_make(str_get(s1));
1212 str = str_make(str_get(s1));
1214 str = str_make(str_get(s2));
1217 if (arg[3].arg_type != A_SINGLE) {
1222 str = str_make(str_get(str_true(s1) ? s2 : arg[3].arg_ptr.arg_str));
1223 str_free(arg[3].arg_ptr.arg_str);
1227 str_numset(str,(double)(-str_gnum(s1)));
1230 str_numset(str,(double)(!str_true(s1)));
1233 str_numset(str,(double)(~(long)str_gnum(s1)));
1236 str_numset(str, (double)str_len(s1));
1239 if (arg[3].arg_type != A_SINGLE || stabent("[",allstabs)) {
1240 str_free(str); /* making the fallacious assumption */
1241 str = Nullstr; /* that any $[ occurs before substr()*/
1245 int len = (int)str_gnum(s2);
1248 for (beg = str_get(s1); *beg && len > 0; beg++,len--) ;
1249 len = (int)str_gnum(arg[3].arg_ptr.arg_str);
1250 str_free(arg[3].arg_ptr.arg_str);
1251 if (len > (tmp = strlen(beg)))
1253 str_nset(str,beg,len);
1258 str_numset(str,(double)(strLT(tmps,str_get(s2))));
1262 str_numset(str,(double)(strGT(tmps,str_get(s2))));
1266 str_numset(str,(double)(strLE(tmps,str_get(s2))));
1270 str_numset(str,(double)(strGE(tmps,str_get(s2))));
1274 str_numset(str,(double)(strEQ(tmps,str_get(s2))));
1278 str_numset(str,(double)(strNE(tmps,str_get(s2))));
1283 str_set(str,crypt(tmps,str_get(s2)));
1286 "The crypt() function is unimplemented due to excessive paranoia.");
1290 str_numset(str,exp(str_gnum(s1)));
1293 str_numset(str,log(str_gnum(s1)));
1296 str_numset(str,sqrt(str_gnum(s1)));
1299 value = str_gnum(s1);
1303 modf(-value,&value);
1306 str_numset(str,value);
1309 str_numset(str,(double)(*str_get(s1)));
1313 arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */
1316 arg[1].arg_ptr.arg_str = str;
1329 arg->arg_flags |= AF_COMMON; /* XXX should cross-match */
1330 /* this does unnecessary copying */
1332 if (arg[1].arg_type == A_ARYLEN) {
1333 arg[1].arg_type = A_LARYLEN;
1337 /* see if it's an array reference */
1339 if (arg[1].arg_type == A_EXPR) {
1340 arg1 = arg[1].arg_ptr.arg_arg;
1342 if (arg1->arg_type == O_LIST && arg->arg_type != O_ITEM) {
1343 /* assign to list */
1344 arg[1].arg_flags |= AF_SPECIAL;
1346 arg[2].arg_flags |= AF_SPECIAL;
1347 for (i = arg1->arg_len; i >= 1; i--) {
1348 switch (arg1[i].arg_type) {
1349 case A_STAB: case A_LVAL:
1350 arg1[i].arg_type = A_LVAL;
1352 case A_EXPR: case A_LEXPR:
1353 arg1[i].arg_type = A_LEXPR;
1354 if (arg1[i].arg_ptr.arg_arg->arg_type == O_ARRAY)
1355 arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY;
1356 else if (arg1[i].arg_ptr.arg_arg->arg_type == O_HASH)
1357 arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH;
1358 if (arg1[i].arg_ptr.arg_arg->arg_type == O_LARRAY)
1360 if (arg1[i].arg_ptr.arg_arg->arg_type == O_LHASH)
1365 "Illegal item (%s) as lvalue",argname[arg1[i].arg_type]);
1370 else if (arg1->arg_type == O_ARRAY) {
1371 if (arg1->arg_len == 1 && arg->arg_type != O_ITEM) {
1372 /* assign to array */
1373 arg[1].arg_flags |= AF_SPECIAL;
1375 arg[2].arg_flags |= AF_SPECIAL;
1378 arg1->arg_type = O_LARRAY; /* assign to array elem */
1380 else if (arg1->arg_type == O_HASH)
1381 arg1->arg_type = O_LHASH;
1382 else if (arg1->arg_type != O_ASSIGN) {
1384 "Illegal expression (%s) as lvalue",opname[arg1->arg_type]);
1387 arg[1].arg_type = A_LEXPR;
1390 fprintf(stderr,"lval LEXPR\n");
1395 /* not an array reference, should be a register name */
1397 if (arg[1].arg_type != A_STAB && arg[1].arg_type != A_LVAL) {
1399 "Illegal item (%s) as lvalue",argname[arg[1].arg_type]);
1402 arg[1].arg_type = A_LVAL;
1405 fprintf(stderr,"lval LVAL\n");
1415 if (arg[i].arg_type != A_EXPR) { /* dehoist */
1416 tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg,0);
1418 arg[i].arg_ptr.arg_arg = tmparg;
1419 arg[i].arg_type = A_EXPR;
1424 addflags(i,flags,arg)
1427 arg[i].arg_flags |= flags;
1435 if (arg->arg_type == O_ARRAY)
1436 return make_op(O_ITEM,1,arg,Nullarg,Nullarg,0);
1446 register ARG *nxtnode;
1452 arg->arg_type = O_LIST;
1454 if (arg->arg_type != O_COMMA) {
1455 arg->arg_flags |= AF_LISTISH; /* see listish() below */
1458 for (i = 2, node = arg; ; i++) {
1459 if (node->arg_len < 2)
1461 if (node[2].arg_type != A_EXPR)
1463 node = node[2].arg_ptr.arg_arg;
1464 if (node->arg_type != O_COMMA)
1470 tmpstr = arg->arg_ptr.arg_str;
1471 *arg = *node; /* copy everything except the STR */
1472 arg->arg_ptr.arg_str = tmpstr;
1475 ++j; /* Bug in Xenix compiler */
1481 nxtnode = node[2].arg_ptr.arg_arg;
1486 arg->arg_type = O_LIST;
1491 /* turn a single item into a list */
1497 if (arg->arg_flags & AF_LISTISH) {
1498 arg = make_op(O_LIST,1,arg,Nullarg,Nullarg,0);
1499 arg[1].arg_flags &= ~AF_SPECIAL;
1504 /* mark list of local variables */
1510 arg->arg_flags |= AF_LOCAL;
1515 stab2arg(atype,stab)
1517 register STAB *stab;
1522 arg->arg_type = O_ITEM;
1523 arg[1].arg_type = atype;
1524 arg[1].arg_ptr.arg_stab = stab;
1530 register char *cval;
1535 arg->arg_type = O_ITEM;
1536 arg[1].arg_type = A_SINGLE;
1537 arg[1].arg_ptr.arg_str = str_make(cval);
1548 arg = (ARG*)safemalloc((numargs + 1) * sizeof (ARG));
1549 bzero((char *)arg, (numargs + 1) * sizeof (ARG));
1550 arg->arg_ptr.arg_str = str_new(0);
1551 arg->arg_len = numargs;
1559 str_free(arg->arg_ptr.arg_str);
1560 safefree((char*)arg);
1564 make_match(type,expr,spat)
1571 arg = make_op(type,2,expr,Nullarg,Nullarg,0);
1573 arg[2].arg_type = A_SPAT;
1574 arg[2].arg_ptr.arg_spat = spat;
1577 fprintf(stderr,"make_match SPAT=%lx\n",(long)spat);
1580 if (type == O_SUBST || type == O_NSUBST) {
1581 if (arg[1].arg_type != A_STAB)
1582 yyerror("Illegal lvalue");
1583 arg[1].arg_type = A_LVAL;
1595 arg->arg_type = O_ITEM;
1596 arg[1].arg_type = A_CMD;
1597 arg[1].arg_ptr.arg_cmd = cmd;
1606 register ARG *arg = cmd->c_expr;
1609 /* hoist "while (<channel>)" up into command block */
1611 if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) {
1612 cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
1613 cmd->c_flags |= CFT_GETS; /* and set it to do the input */
1614 cmd->c_stab = arg[1].arg_ptr.arg_stab;
1615 if (arg[1].arg_ptr.arg_stab->stab_io->flags & IOF_ARGV) {
1616 cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */
1617 stab2arg(A_LVAL,defstab), arg, Nullarg,1 ));
1621 cmd->c_expr = Nullarg;
1624 else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) {
1625 cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
1626 cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */
1627 cmd->c_stab = arg[1].arg_ptr.arg_stab;
1629 cmd->c_expr = Nullarg;
1631 else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) {
1632 if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY)
1633 asgnstab = cmd->c_stab;
1636 cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */
1637 stab2arg(A_LVAL,asgnstab), arg, Nullarg,1 ));
1638 cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
1641 /* First find the end of the true list */
1643 if (cmd->ucmd.ccmd.cc_true == Nullcmd)
1645 for (tail = cmd->ucmd.ccmd.cc_true; tail->c_next; tail = tail->c_next) ;
1647 /* if there's a continue block, link it to true block and find end */
1649 if (cmd->ucmd.ccmd.cc_alt != Nullcmd) {
1650 tail->c_next = cmd->ucmd.ccmd.cc_alt;
1651 for ( ; tail->c_next; tail = tail->c_next) ;
1654 /* Here's the real trick: link the end of the list back to the beginning,
1655 * inserting a "last" block to break out of the loop. This saves one or
1656 * two procedure calls every time through the loop, because of how cmd_exec
1657 * does tail recursion.
1660 tail->c_next = (CMD *) safemalloc(sizeof (CMD));
1661 tail = tail->c_next;
1662 if (!cmd->ucmd.ccmd.cc_alt)
1663 cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */
1665 bcopy((char *)cmd, (char *)tail, sizeof(CMD));
1666 tail->c_type = C_EXPR;
1667 tail->c_flags ^= CF_INVERT; /* turn into "last unless" */
1668 tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */
1669 tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg,0);
1670 tail->ucmd.acmd.ac_stab = Nullstab;
1679 /* hoist "for $foo (@bar)" up into command block */
1681 cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */
1682 cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */
1683 cmd->c_stab = eachstab;
1688 static int gensym = 0;
1693 sprintf(tokenbuf,"_GEN_%d",gensym++);
1694 return stabent(tokenbuf,TRUE);
1697 /* this routine is in perly.c by virtue of being sort of an alternate main() */
1708 char *oldfile = filename;
1709 line_t oldline = line;
1710 int oldtmps_base = tmps_base;
1711 int oldsave = savestack->ary_fill;
1713 tmps_base = tmps_max;
1714 str_set(stabent("@",TRUE)->stab_val,"");
1715 if (optype != O_DOFILE) { /* normal eval */
1716 filename = "(eval)";
1718 str_sset(linestr,str);
1721 filename = savestr(str_get(str)); /* can't free this easily */
1722 str_set(linestr,"");
1723 rsfp = fopen(filename,"r");
1724 ar = incstab->stab_array;
1725 if (!rsfp && *filename != '/') {
1726 for (i = 0; i <= ar->ary_fill; i++) {
1727 sprintf(tokenbuf,"%s/%s",str_get(afetch(ar,i)),filename);
1728 rsfp = fopen(tokenbuf,"r");
1731 filename = savestr(tokenbuf);
1738 tmps_base = oldtmps_base;
1744 bufptr = str_get(linestr);
1745 if (setjmp(eval_env))
1749 myroot = eval_root; /* in case cmd_exec does another eval! */
1753 str = str_static(cmd_exec(eval_root));
1754 /* if we don't save str, free zaps it */
1755 cmd_free(myroot); /* can't free on error, for some reason */
1760 tmps_base = oldtmps_base;
1761 if (savestack->ary_fill > oldsave) /* let them use local() */
1762 restorelist(oldsave);
1769 register CMD *tofree;
1770 register CMD *head = cmd;
1773 if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */
1775 safefree(cmd->c_label);
1777 str_free(cmd->c_short);
1779 spat_free(cmd->c_spat);
1781 arg_free(cmd->c_expr);
1783 switch (cmd->c_type) {
1787 if (cmd->ucmd.ccmd.cc_true)
1788 cmd_free(cmd->ucmd.ccmd.cc_true);
1789 if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
1790 cmd_free(cmd->ucmd.ccmd.cc_alt);
1793 if (cmd->ucmd.acmd.ac_expr)
1794 arg_free(cmd->ucmd.acmd.ac_expr);
1799 safefree((char*)tofree);
1800 if (cmd && cmd == head) /* reached end of while loop */
1810 for (i = 1; i <= arg->arg_len; i++) {
1811 switch (arg[i].arg_type) {
1816 arg_free(arg[i].arg_ptr.arg_arg);
1819 cmd_free(arg[i].arg_ptr.arg_cmd);
1831 str_free(arg[i].arg_ptr.arg_str);
1834 spat_free(arg[i].arg_ptr.arg_spat);
1844 register SPAT *spat;
1848 if (spat->spat_runtime)
1849 arg_free(spat->spat_runtime);
1850 if (spat->spat_repl) {
1851 arg_free(spat->spat_repl);
1853 if (spat->spat_short) {
1854 str_free(spat->spat_short);
1856 if (spat->spat_regexp) {
1857 regfree(spat->spat_regexp);
1860 /* now unlink from spat list */
1861 if (spat_root == spat)
1862 spat_root = spat->spat_next;
1864 for (sp = spat_root; sp->spat_next != spat; sp = sp->spat_next) ;
1865 sp->spat_next = spat->spat_next;
1868 safefree((char*)spat);
1871 /* Recursively descend a command sequence and push the address of any string
1872 * that needs saving on recursion onto the tosave array.
1879 register CMD *head = cmd;
1883 spat_tosave(cmd->c_spat);
1885 arg_tosave(cmd->c_expr);
1886 switch (cmd->c_type) {
1890 if (cmd->ucmd.ccmd.cc_true)
1891 cmd_tosave(cmd->ucmd.ccmd.cc_true);
1892 if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt)
1893 cmd_tosave(cmd->ucmd.ccmd.cc_alt);
1896 if (cmd->ucmd.acmd.ac_expr)
1897 arg_tosave(cmd->ucmd.acmd.ac_expr);
1901 if (cmd && cmd == head) /* reached end of while loop */
1913 for (i = 1; i <= arg->arg_len; i++) {
1914 switch (arg[i].arg_type) {
1919 saving |= arg_tosave(arg[i].arg_ptr.arg_arg);
1922 cmd_tosave(arg[i].arg_ptr.arg_cmd);
1923 saving = TRUE; /* assume hanky panky */
1936 saving |= spat_tosave(arg[i].arg_ptr.arg_spat);
1942 switch (arg->arg_type) {
1948 apush(tosave,arg->arg_ptr.arg_str);
1954 register SPAT *spat;
1958 if (spat->spat_runtime)
1959 saving |= arg_tosave(spat->spat_runtime);
1960 if (spat->spat_repl) {
1961 saving |= arg_tosave(spat->spat_repl);