home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / perl / Source / C / Toke < prev    next >
Encoding:
Text File  |  1991-02-09  |  52.2 KB  |  2,302 lines
  1. /* $Header: toke.c,v 3.0.1.12 91/01/11 18:31:45 lwall Locked $
  2.  *
  3.  *    Copyright (c) 1989, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of the GNU General Public License
  6.  *    as specified in the README file that comes with the perl 3.0 kit.
  7.  *
  8.  * $Log:    toke.c,v $
  9.  * Revision 3.0.1.12  91/01/11  18:31:45  lwall
  10.  * patch42: eval'ed formats without proper termination blew up
  11.  * patch42: whitespace now allowed after terminating . of format
  12.  * 
  13.  * Revision 3.0.1.11  90/11/10  02:13:44  lwall
  14.  * patch38: added alarm function
  15.  * patch38: tr was busted in metacharacters on signed char machines
  16.  * 
  17.  * Revision 3.0.1.10  90/10/16  11:20:46  lwall
  18.  * patch29: the length of a search pattern was limited
  19.  * patch29: added DATA filehandle to read stuff after __END__
  20.  * patch29: added -M, -A and -C
  21.  * patch29: added cmp and <=>
  22.  * patch29: added caller
  23.  * patch29: added scalar
  24.  * patch29: added sysread and syswrite
  25.  * patch29: added SysV IPC
  26.  * patch29: added waitpid
  27.  * patch29: tr/// now understands c, d and s options, and handles nulls right
  28.  * patch29: 0x80000000 now makes unsigned value
  29.  * patch29: Null could not be used as a delimiter
  30.  * patch29: added @###.## fields to format
  31.  * 
  32.  * Revision 3.0.1.9  90/08/13  22:37:25  lwall
  33.  * patch28: defined(@array) and defined(%array) didn't work right
  34.  * 
  35.  * Revision 3.0.1.8  90/08/09  05:39:58  lwall
  36.  * patch19: added require operator
  37.  * patch19: added -x switch to extract script from input trash
  38.  * patch19: bare @name didn't add array to symbol table
  39.  * patch19: Added __LINE__ and __FILE__ tokens
  40.  * patch19: Added __END__ token
  41.  * patch19: Numeric literals are now stored only in floating point
  42.  * patch19: some support for FPS compiler misfunction
  43.  * patch19: "\\$foo" not handled right
  44.  * patch19: program and data can now both come from STDIN
  45.  * patch19: "here" strings caused warnings about uninitialized variables
  46.  * 
  47.  * Revision 3.0.1.7  90/03/27  16:32:37  lwall
  48.  * patch16: MSDOS support
  49.  * patch16: formats didn't work inside eval
  50.  * patch16: final semicolon in program wasn't optional with -p or -n
  51.  * 
  52.  * Revision 3.0.1.6  90/03/12  17:06:36  lwall
  53.  * patch13: last semicolon of program is now optional, just for Randal
  54.  * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
  55.  * 
  56.  * Revision 3.0.1.5  90/02/28  18:47:06  lwall
  57.  * patch9: return grandfathered to never be function call
  58.  * patch9: non-existent perldb.pl now gives reasonable error message
  59.  * patch9: perl can now start up other interpreters scripts
  60.  * patch9: line numbers were bogus during certain portions of foreach evaluation
  61.  * patch9: null hereis core dumped
  62.  * 
  63.  * Revision 3.0.1.4  89/12/21  20:26:56  lwall
  64.  * patch7: -d switch incompatible with -p or -n
  65.  * patch7: " ''$foo'' " didn't parse right
  66.  * patch7: grandfathered m'pat' and s'pat'repl' to not be package qualifiers
  67.  * 
  68.  * Revision 3.0.1.3  89/11/17  15:43:15  lwall
  69.  * patch5: IBM PC/RT compiler can't deal with UNI() and LOP() macros
  70.  * patch5: } misadjusted expection of subsequent term or operator
  71.  * patch5: y/abcde// didn't work
  72.  * 
  73.  * Revision 3.0.1.2  89/11/11  05:04:42  lwall
  74.  * patch2: fixed a CLINE macro conflict
  75.  * 
  76.  * Revision 3.0.1.1  89/10/26  23:26:21  lwall
  77.  * patch1: disambiguated word after "sort" better
  78.  * 
  79.  * Revision 3.0  89/10/18  15:32:33  lwall
  80.  * 3.0 baseline
  81.  * 
  82.  */
  83.  
  84. #include "EXTERN.h"
  85. #include "perl.h"
  86. #include "perly.h"
  87.  
  88. /* which backslash sequences to keep in m// or s// */
  89.  
  90. static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtf0123456789[{]}";
  91.  
  92. char *reparse;        /* if non-null, scanreg found ${foo[$bar]} */
  93.  
  94. #ifdef CLINE
  95. #undef CLINE
  96. #endif
  97. #define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))
  98.  
  99. #define META(c) ((c) | 128)
  100.  
  101. #define RETURN(retval) return (bufptr = s,(int)retval)
  102. #define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,(int)retval)
  103. #define TERM(retval) return (CLINE, expectterm = FALSE,bufptr = s,(int)retval)
  104. #define LOOPX(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LOOPEX)
  105. #define FTST(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)FILETEST)
  106. #define FUN0(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC0)
  107. #define FUN1(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC1)
  108. #define FUN2(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2)
  109. #define FUN2x(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2x)
  110. #define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3)
  111. #define FUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC4)
  112. #define FUN5(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC5)
  113. #define FL(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST)
  114. #define FL2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST2)
  115. #define HFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)HSHFUN)
  116. #define HFUN3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)HSHFUN3)
  117. #define LFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LVALFUN)
  118. #define AOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)ADDOP)
  119. #define MOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)MULOP)
  120. #define EOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)EQOP)
  121. #define ROP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)RELOP)
  122. #define FOP(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP)
  123. #define FOP2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP2)
  124. #define FOP3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP3)
  125. #define FOP4(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP4)
  126. #define FOP22(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP22)
  127. #define FOP25(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP25)
  128.  
  129. /* This bit of chicanery makes a unary function followed by
  130.  * a parenthesis into a function with one argument, highest precedence.
  131.  */
  132. #define UNI(f) return(yylval.ival = f,expectterm = TRUE,bufptr = s, \
  133.     (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
  134.  
  135. /* This does similarly for list operators, merely by pretending that the
  136.  * paren came before the listop rather than after.
  137.  */
  138. #define LOP(f) return(*s == '(' || (s = skipspace(s), *s == '(') ? \
  139.     (*s = META('('), bufptr = oldbufptr, '(') : \
  140.     (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
  141. /* grandfather return to old style */
  142. #define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)
  143.  
  144. char *skipspace (register char *s)
  145. {
  146.     while (s < bufend && isascii(*s) && isspace(*s))
  147.     s++;
  148.     return s;
  149. }
  150.  
  151. #ifdef CRIPPLED_CC
  152.  
  153. #undef UNI
  154. #undef LOP
  155. #define UNI(f) return uni(f,s)
  156. #define LOP(f) return lop(f,s)
  157.  
  158. int uni (int f, char *s)
  159. {
  160.     yylval.ival = f;
  161.     expectterm = TRUE;
  162.     bufptr = s;
  163.     if (*s == '(')
  164.     return FUNC1;
  165.     s = skipspace(s);
  166.     if (*s == '(')
  167.     return FUNC1;
  168.     else
  169.     return UNIOP;
  170. }
  171.  
  172. int lop (int f, char *s)
  173. {
  174.     if (*s != '(')
  175.     s = skipspace(s);
  176.     if (*s == '(') {
  177.     *s = META('(');
  178.     bufptr = oldbufptr;
  179.     return '(';
  180.     }
  181.     else {
  182.     yylval.ival=f;
  183.     expectterm = TRUE;
  184.     bufptr = s;
  185.     return LISTOP;
  186.     }
  187. }
  188.  
  189. #endif /* CRIPPLED_CC */
  190.  
  191. int yylex (void)
  192. {
  193.     register char *s = bufptr;
  194.     register char *d;
  195.     register int tmp;
  196.     static bool in_format = FALSE;
  197.     static bool firstline = TRUE;
  198.  
  199.     oldoldbufptr = oldbufptr;
  200.     oldbufptr = s;
  201.  
  202.   retry:
  203. #ifdef YYDEBUG
  204.     if (debug & 1)
  205.     {
  206.     if (index(s,'\n'))
  207.         fprintf(stderr,"Tokener at %s",s);
  208.     else
  209.         fprintf(stderr,"Tokener at %s\n",s);
  210.     }
  211. #endif
  212. #ifdef BADSWITCH
  213.     if (*s & 128) {
  214.     if ((*s & 127) == '(')
  215.         *s++ = '(';
  216.     else
  217.         warn("Unrecognized character \\%03o ignored", *s++);
  218.     goto retry;
  219.     }
  220. #endif
  221.     switch (*s) {
  222.     default:
  223.     if ((*s & 127) == '(')
  224.         *s++ = '(';
  225.     else
  226.         warn("Unrecognized character \\%03o ignored", *s++);
  227.     goto retry;
  228.     case 4:
  229.     case 26:
  230.     goto fake_eof;            /* emulate EOF on ^D or ^Z */
  231.     case 0:
  232.     if (!rsfp)
  233.         RETURN(0);
  234.     if (s++ < bufend)
  235.         goto retry;            /* ignore stray nulls */
  236.     if (firstline) {
  237.         firstline = FALSE;
  238.         if (minus_n || minus_p || perldb) {
  239.         str_set(linestr,"");
  240.         if (perldb) {
  241.             char *pdb = getenv("Perl$DB");
  242.  
  243.             str_cat(linestr, pdb ? pdb : "require 'Perldb'");
  244.             str_cat(linestr, ";");
  245.         }
  246.         if (minus_n || minus_p) {
  247.             str_cat(linestr,"line: while (<>) {");
  248.             if (minus_a)
  249.             str_cat(linestr,"@F=split(' ');");
  250.         }
  251.         oldoldbufptr = oldbufptr = s = str_get(linestr);
  252.         bufend = linestr->str_ptr + linestr->str_cur;
  253.         goto retry;
  254.         }
  255.     }
  256.     if (in_format) {
  257.         bufptr = bufend;
  258.         yylval.formval = load_format();
  259.         in_format = FALSE;
  260.         oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
  261.         bufend = linestr->str_ptr + linestr->str_cur;
  262.         OPERATOR(FORMLIST);
  263.     }
  264.     curcmd->c_line++;
  265. #ifdef CRYPTSCRIPT
  266.     cryptswitch();
  267. #endif /* CRYPTSCRIPT */
  268.     do {
  269.         if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
  270.           fake_eof:
  271.         if (rsfp) {
  272.             if (preprocess)
  273.             (void)mypclose(rsfp);
  274.             else if (rsfp == stdin)
  275.             clearerr(stdin);
  276.             else
  277.             (void)fclose(rsfp);
  278.             rsfp = Nullfp;
  279.         }
  280.         if (minus_n || minus_p) {
  281.             str_set(linestr,minus_p ? ";}continue{print" : "");
  282.             str_cat(linestr,";}");
  283.             oldoldbufptr = oldbufptr = s = str_get(linestr);
  284.             bufend = linestr->str_ptr + linestr->str_cur;
  285.             minus_n = minus_p = 0;
  286.             goto retry;
  287.         }
  288.         oldoldbufptr = oldbufptr = s = str_get(linestr);
  289.         str_set(linestr,"");
  290.         RETURN(';');    /* not infinite loop because rsfp is NULL now */
  291.         }
  292.         if (doextract && *linestr->str_ptr == '#')
  293.         doextract = FALSE;
  294.     } while (doextract);
  295.     oldoldbufptr = oldbufptr = bufptr = s;
  296.     if (perldb) {
  297.         STR *str = Str_new(85,0);
  298.  
  299.         str_sset(str,linestr);
  300.         astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
  301.     }
  302. #ifdef DEBUG
  303.     if (firstline) {
  304.         char *showinput();
  305.         s = showinput();
  306.     }
  307. #endif
  308.     bufend = linestr->str_ptr + linestr->str_cur;
  309.     if (curcmd->c_line == 1) {
  310.         if (*s == '#' && s[1] == '!') {
  311.         if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
  312.             char **newargv;
  313.             char *cmd;
  314.  
  315.             s += 2;
  316.             if (*s == ' ')
  317.             s++;
  318.             cmd = s;
  319.             while (s < bufend && !isspace(*s))
  320.             s++;
  321.             *s++ = '\0';
  322.             while (s < bufend && isspace(*s))
  323.             s++;
  324.             if (s < bufend) {
  325.             Newz(899,newargv,origargc+3,char*);
  326.             newargv[1] = s;
  327.             while (s < bufend && !isspace(*s))
  328.                 s++;
  329.             *s = '\0';
  330.             Copy(origargv+1, newargv+2, origargc+1, char*);
  331.             }
  332.             else
  333.             newargv = origargv;
  334.             newargv[0] = cmd;
  335.             execv(cmd,newargv);
  336.             fatal("Can't exec %s", cmd);
  337.         }
  338.         }
  339.         else {
  340.         while (s < bufend && isspace(*s))
  341.             s++;
  342.         if (*s == ':')    /* for csh's that have to exec sh scripts */
  343.             s++;
  344.         }
  345.     }
  346.     goto retry;
  347.     case ' ': case '\t': case '\f':
  348.     s++;
  349.     goto retry;
  350.     case '#':
  351.     if (preprocess && s == str_get(linestr) &&
  352.            s[1] == ' ' && isdigit(s[2])) {
  353.         curcmd->c_line = atoi(s+2)-1;
  354.         for (s += 2; isdigit(*s); s++) ;
  355.         d = bufend;
  356.         while (s < d && isspace(*s)) s++;
  357.         s[strlen(s)-1] = '\0';    /* wipe out newline */
  358.         if (*s == '"') {
  359.         s++;
  360.         s[strlen(s)-1] = '\0';    /* wipe out trailing quote */
  361.         }
  362.         if (*s)
  363.         curcmd->c_filestab = fstab(s);
  364.         else
  365.         curcmd->c_filestab = fstab(origfilename);
  366.         oldoldbufptr = oldbufptr = s = str_get(linestr);
  367.     }
  368.     /* FALL THROUGH */
  369.     case '\n':
  370.     if (in_eval && !rsfp) {
  371.         d = bufend;
  372.         while (s < d && *s != '\n')
  373.         s++;
  374.         if (s < d)
  375.         s++;
  376.         if (perldb) {
  377.         STR *str = Str_new(85,0);
  378.  
  379.         str_nset(str,linestr->str_ptr, s - linestr->str_ptr);
  380.         astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
  381.         str_chop(linestr, s);
  382.         }
  383.         if (in_format) {
  384.         bufptr = s;
  385.         yylval.formval = load_format();
  386.         in_format = FALSE;
  387.         oldoldbufptr = oldbufptr = s = bufptr + 1;
  388.         TERM(FORMLIST);
  389.         }
  390.         curcmd->c_line++;
  391.     }
  392.     else {
  393.         *s = '\0';
  394.         bufend = s;
  395.     }
  396.     goto retry;
  397.     case '-':
  398.     if (s[1] && isalpha(s[1]) && !isalpha(s[2])) {
  399.         s++;
  400.         switch (*s++) {
  401.         case 'r': FTST(O_FTREAD);
  402.         case 'w': FTST(O_FTWRITE);
  403.         case 'L': FTST(O_FTLOCK);
  404.         case 'R': FTST(O_FTPREAD);
  405.         case 'W': FTST(O_FTPWRITE);
  406.         case 'e': FTST(O_FTIS);
  407.         case 'z': FTST(O_FTZERO);
  408.         case 's': FTST(O_FTSIZE);
  409.         case 'f': FTST(O_FTFILE);
  410.         case 'd': FTST(O_FTDIR);
  411.         case 't': FTST(O_FTTTY);
  412.         case 'T': FTST(O_FTTEXT);
  413.         case 'B': FTST(O_FTBINARY);
  414.         case 'A': stabent("\024",TRUE); FTST(O_FTTIME);
  415.         default:
  416.         s -= 2;
  417.         break;
  418.         }
  419.     }
  420.     tmp = *s++;
  421.     if (*s == tmp) {
  422.         s++;
  423.         RETURN(DEC);
  424.     }
  425.     if (expectterm)
  426.         OPERATOR('-');
  427.     else
  428.         AOP(O_SUBTRACT);
  429.     case '+':
  430.     tmp = *s++;
  431.     if (*s == tmp) {
  432.         s++;
  433.         RETURN(INC);
  434.     }
  435.     if (expectterm)
  436.         OPERATOR('+');
  437.     else
  438.         AOP(O_ADD);
  439.  
  440.     case '*':
  441.     if (expectterm) {
  442.         s = scanreg(s,bufend,tokenbuf);
  443.         yylval.stabval = stabent(tokenbuf,TRUE);
  444.         TERM(STAR);
  445.     }
  446.     tmp = *s++;
  447.     if (*s == tmp) {
  448.         s++;
  449.         OPERATOR(POW);
  450.     }
  451.     MOP(O_MULTIPLY);
  452.     case '%':
  453.     if (expectterm) {
  454.         s = scanreg(s,bufend,tokenbuf);
  455.         yylval.stabval = hadd(stabent(tokenbuf,TRUE));
  456.         TERM(HSH);
  457.     }
  458.     s++;
  459.     MOP(O_MODULO);
  460.  
  461.     case '^':
  462.     case '~':
  463.     case '(':
  464.     case ',':
  465.     case ':':
  466.     case '[':
  467.     tmp = *s++;
  468.     OPERATOR(tmp);
  469.     case '{':
  470.     tmp = *s++;
  471.     if (isspace(*s) || *s == '#')
  472.         cmdline = NOLINE;   /* invalidate current command line number */
  473.     OPERATOR(tmp);
  474.     case ';':
  475.     if (curcmd->c_line < cmdline)
  476.         cmdline = curcmd->c_line;
  477.     tmp = *s++;
  478.     OPERATOR(tmp);
  479.     case ')':
  480.     case ']':
  481.     tmp = *s++;
  482.     TERM(tmp);
  483.     case '}':
  484.     tmp = *s++;
  485.     RETURN(tmp);
  486.     case '&':
  487.     s++;
  488.     tmp = *s++;
  489.     if (tmp == '&')
  490.         OPERATOR(ANDAND);
  491.     s--;
  492.     if (expectterm) {
  493.         d = bufend;
  494.         while (s < d && isspace(*s))
  495.         s++;
  496.         if (isalpha(*s) || *s == '_' || *s == '\'')
  497.         *(--s) = '\\';    /* force next ident to WORD */
  498.         OPERATOR(AMPER);
  499.     }
  500.     OPERATOR('&');
  501.     case '|':
  502.     s++;
  503.     tmp = *s++;
  504.     if (tmp == '|')
  505.         OPERATOR(OROR);
  506.     s--;
  507.     OPERATOR('|');
  508.     case '=':
  509.     s++;
  510.     tmp = *s++;
  511.     if (tmp == '=')
  512.         EOP(O_EQ);
  513.     if (tmp == '~')
  514.         OPERATOR(MATCH);
  515.     s--;
  516.     OPERATOR('=');
  517.     case '!':
  518.     s++;
  519.     tmp = *s++;
  520.     if (tmp == '=')
  521.         EOP(O_NE);
  522.     if (tmp == '~')
  523.         OPERATOR(NMATCH);
  524.     s--;
  525.     OPERATOR('!');
  526.     case '<':
  527.     if (expectterm) {
  528.         s = scanstr(s);
  529.         TERM(RSTRING);
  530.     }
  531.     s++;
  532.     tmp = *s++;
  533.     if (tmp == '<')
  534.         OPERATOR(LS);
  535.     if (tmp == '=') {
  536.         tmp = *s++;
  537.         if (tmp == '>')
  538.         EOP(O_NCMP);
  539.         s--;
  540.         ROP(O_LE);
  541.     }
  542.     s--;
  543.     ROP(O_LT);
  544.     case '>':
  545.     s++;
  546.     tmp = *s++;
  547.     if (tmp == '>')
  548.         OPERATOR(RS);
  549.     if (tmp == '=')
  550.         ROP(O_GE);
  551.     s--;
  552.     ROP(O_GT);
  553.  
  554. #define SNARFWORD \
  555.     d = tokenbuf; \
  556.     while (isascii(*s) && \
  557.       (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'')) \
  558.         *d++ = *s++; \
  559.     while (d[-1] == '\'') \
  560.         d--,s--; \
  561.     *d = '\0'; \
  562.     d = tokenbuf;
  563.  
  564.     case '$':
  565.     if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
  566.         s++;
  567.         s = scanreg(s,bufend,tokenbuf);
  568.         yylval.stabval = aadd(stabent(tokenbuf,TRUE));
  569.         TERM(ARYLEN);
  570.     }
  571.     d = s;
  572.     s = scanreg(s,bufend,tokenbuf);
  573.     if (reparse) {        /* turn ${foo[bar]} into ($foo[bar]) */
  574.       do_reparse:
  575.         s[-1] = ')';
  576.         s = d;
  577.         s[1] = s[0];
  578.         s[0] = '(';
  579.         goto retry;
  580.     }
  581.     yylval.stabval = stabent(tokenbuf,TRUE);
  582.     TERM(REG);
  583.  
  584.     case '@':
  585.     d = s;
  586.     s = scanreg(s,bufend,tokenbuf);
  587.     if (reparse)
  588.         goto do_reparse;
  589.     yylval.stabval = aadd(stabent(tokenbuf,TRUE));
  590.     TERM(ARY);
  591.  
  592.     case '/':            /* may either be division or pattern */
  593.     case '?':            /* may either be conditional or pattern */
  594.     if (expectterm) {
  595.         s = scanpat(s);
  596.         TERM(PATTERN);
  597.     }
  598.     tmp = *s++;
  599.     if (tmp == '/')
  600.         MOP(O_DIVIDE);
  601.     OPERATOR(tmp);
  602.  
  603.     case '.':
  604.     if (!expectterm || !isdigit(s[1])) {
  605.         tmp = *s++;
  606.         if (*s == tmp) {
  607.         s++;
  608.         OPERATOR(DOTDOT);
  609.         }
  610.         AOP(O_CONCAT);
  611.     }
  612.     /* FALL THROUGH */
  613.     case '0': case '1': case '2': case '3': case '4':
  614.     case '5': case '6': case '7': case '8': case '9':
  615.     case '\'': case '"': case '`':
  616.     s = scanstr(s);
  617.     TERM(RSTRING);
  618.  
  619.     case '\\':    /* some magic to force next word to be a WORD */
  620.     s++;    /* used by do and sub to force a separate namespace */
  621.     /* FALL THROUGH */
  622.     case '_':
  623.     SNARFWORD;
  624.     if (d[1] == '_') {
  625.         if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
  626.         ARG *arg = op_new(1);
  627.  
  628.         yylval.arg = arg;
  629.         arg->arg_type = O_ITEM;
  630.         if (d[2] == 'L')
  631.             (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
  632.         else
  633.             strcpy(tokenbuf, stab_val(curcmd->c_filestab)->str_ptr);
  634.         arg[1].arg_type = A_SINGLE;
  635.         arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
  636.         TERM(RSTRING);
  637.         }
  638.         else if (strEQ(d,"__END__")) {
  639. #ifndef TAINT
  640.         STAB *stab;
  641.  
  642.         if ((stab = stabent("DATA",FALSE)) != Nullstab) {
  643.             stab->str_pok |= SP_MULTI;
  644.             stab_io(stab) = stio_new();
  645.             stab_io(stab)->ifp = rsfp;
  646.             if (preprocess)
  647.             stab_io(stab)->type = '|';
  648.             else if (rsfp == stdin)
  649.             stab_io(stab)->type = '-';
  650.             else
  651.             stab_io(stab)->type = '<';
  652.             rsfp = Nullfp;
  653.         }
  654. #endif
  655.         goto fake_eof;
  656.         }
  657.     }
  658.     break;
  659.     case 'a': case 'A':
  660.     SNARFWORD;
  661.     if (strEQ(d,"atan2"))
  662.         FUN2(O_ATAN2);
  663.     break;
  664.     case 'b': case 'B':
  665.     SNARFWORD;
  666.     break;
  667.     case 'c': case 'C':
  668.     SNARFWORD;
  669.     if (strEQ(d,"chop"))
  670.         LFUN(O_CHOP);
  671.     if (strEQ(d,"continue"))
  672.         OPERATOR(CONTINUE);
  673.     if (strEQ(d,"chdir"))
  674.         UNI(O_CHDIR);
  675.     if (strEQ(d,"close"))
  676.         FOP(O_CLOSE);
  677.     if (strEQ(d,"closedir"))
  678.         FOP(O_CLOSEDIR);
  679.     if (strEQ(d,"cmp"))
  680.         EOP(O_SCMP);
  681.     if (strEQ(d,"caller"))
  682.         UNI(O_CALLER);
  683.     if (strEQ(d,"crypt")) {
  684. #ifdef FCRYPT
  685.         init_des();
  686. #endif
  687.         FUN2(O_CRYPT);
  688.     }
  689.     if (strEQ(d,"cos"))
  690.         UNI(O_COS);
  691.     break;
  692.     case 'd': case 'D':
  693.     SNARFWORD;
  694.     if (strEQ(d,"do")) {
  695.         d = bufend;
  696.         while (s < d && isspace(*s))
  697.         s++;
  698.         if (isalpha(*s) || *s == '_')
  699.         *(--s) = '\\';    /* force next ident to WORD */
  700.         OPERATOR(DO);
  701.     }
  702.     if (strEQ(d,"die"))
  703.         LOP(O_DIE);
  704.     if (strEQ(d,"defined"))
  705.         LFUN(O_DEFINED);
  706.     if (strEQ(d,"delete"))
  707.         OPERATOR(DELETE);
  708.     if (strEQ(d,"dbmopen"))
  709.         HFUN3(O_DBMOPEN);
  710.     if (strEQ(d,"dbmclose"))
  711.         HFUN(O_DBMCLOSE);
  712.     break;
  713.     case 'e': case 'E':
  714.     SNARFWORD;
  715.     if (strEQ(d,"else"))
  716.         OPERATOR(ELSE);
  717.     if (strEQ(d,"elsif")) {
  718.         yylval.ival = curcmd->c_line;
  719.         OPERATOR(ELSIF);
  720.     }
  721.     if (strEQ(d,"eq") || strEQ(d,"EQ"))
  722.         EOP(O_SEQ);
  723.     if (strEQ(d,"exit"))
  724.         UNI(O_EXIT);
  725.     if (strEQ(d,"eval")) {
  726.         allstabs = TRUE;        /* must initialize everything since */
  727.         UNI(O_EVAL);        /* we don't know what will be used */
  728.     }
  729.     if (strEQ(d,"eof"))
  730.         FOP(O_EOF);
  731.     if (strEQ(d,"exp"))
  732.         UNI(O_EXP);
  733.     if (strEQ(d,"each"))
  734.         HFUN(O_EACH);
  735.     if (strEQ(d,"exec")) {
  736.         LOP(O_EXEC_OP);
  737.     }
  738.     break;
  739.     case 'f': case 'F':
  740.     SNARFWORD;
  741.     if (strEQ(d,"for") || strEQ(d,"foreach")) {
  742.         yylval.ival = curcmd->c_line;
  743.         OPERATOR(FOR);
  744.     }
  745.     if (strEQ(d,"format")) {
  746.         d = bufend;
  747.         while (s < d && isspace(*s))
  748.         s++;
  749.         if (isalpha(*s) || *s == '_')
  750.         *(--s) = '\\';    /* force next ident to WORD */
  751.         in_format = TRUE;
  752.         allstabs = TRUE;        /* must initialize everything since */
  753.         OPERATOR(FORMAT);        /* we don't know what will be used */
  754.     }
  755.     break;
  756.     case 'g': case 'G':
  757.     SNARFWORD;
  758.     if (strEQ(d,"gt") || strEQ(d,"GT"))
  759.         ROP(O_SGT);
  760.     if (strEQ(d,"ge") || strEQ(d,"GE"))
  761.         ROP(O_SGE);
  762.     if (strEQ(d,"grep"))
  763.         FL2(O_GREP);
  764.     if (strEQ(d,"goto"))
  765.         LOOPX(O_GOTO);
  766.     if (strEQ(d,"gmtime"))
  767.         UNI(O_GMTIME);
  768.     if (strEQ(d,"getc"))
  769.         FOP(O_GETC);
  770.     break;
  771.     case 'h': case 'H':
  772.     SNARFWORD;
  773.     if (strEQ(d,"hex"))
  774.         UNI(O_HEX);
  775.     break;
  776.     case 'i': case 'I':
  777.     SNARFWORD;
  778.     if (strEQ(d,"if")) {
  779.         yylval.ival = curcmd->c_line;
  780.         OPERATOR(IF);
  781.     }
  782.     if (strEQ(d,"index"))
  783.         FUN2x(O_INDEX);
  784.     if (strEQ(d,"int"))
  785.         UNI(O_INT);
  786.     break;
  787.     case 'j': case 'J':
  788.     SNARFWORD;
  789.     if (strEQ(d,"join"))
  790.         FL2(O_JOIN);
  791.     break;
  792.     case 'k': case 'K':
  793.     SNARFWORD;
  794.     if (strEQ(d,"keys"))
  795.         HFUN(O_KEYS);
  796.     if (strEQ(d,"kill"))
  797.         UNI(O_KILL);
  798.     break;
  799.     case 'l': case 'L':
  800.     SNARFWORD;
  801.     if (strEQ(d,"last"))
  802.         LOOPX(O_LAST);
  803.     if (strEQ(d,"local"))
  804.         OPERATOR(LOCAL);
  805.     if (strEQ(d,"length"))
  806.         UNI(O_LENGTH);
  807.     if (strEQ(d,"lt") || strEQ(d,"LT"))
  808.         ROP(O_SLT);
  809.     if (strEQ(d,"le") || strEQ(d,"LE"))
  810.         ROP(O_SLE);
  811.     if (strEQ(d,"localtime"))
  812.         UNI(O_LOCALTIME);
  813.     if (strEQ(d,"log"))
  814.         UNI(O_LOG);
  815.     break;
  816.     case 'm': case 'M':
  817.     if (s[1] == '\'') {
  818.         d = "m";
  819.         s++;
  820.     }
  821.     else {
  822.         SNARFWORD;
  823.     }
  824.     if (strEQ(d,"m")) {
  825.         s = scanpat(s-1);
  826.         if (yylval.arg)
  827.         TERM(PATTERN);
  828.         else
  829.         RETURN(1);    /* force error */
  830.     }
  831.     if (strEQ(d,"mkdir"))
  832.         UNI(O_MKDIR);
  833.     break;
  834.     case 'n': case 'N':
  835.     SNARFWORD;
  836.     if (strEQ(d,"next"))
  837.         LOOPX(O_NEXT);
  838.     if (strEQ(d,"ne") || strEQ(d,"NE"))
  839.         EOP(O_SNE);
  840.     break;
  841.     case 'o': case 'O':
  842.     SNARFWORD;
  843.     if (strEQ(d,"open"))
  844.         OPERATOR(OPEN);
  845.     if (strEQ(d,"ord"))
  846.         UNI(O_ORD);
  847.     if (strEQ(d,"oct"))
  848.         UNI(O_OCT);
  849.     if (strEQ(d,"opendir"))
  850.         FOP2(O_OPENDIR);
  851.     break;
  852.     case 'p': case 'P':
  853.     SNARFWORD;
  854.     if (strEQ(d,"print")) {
  855.         checkcomma(s,"filehandle");
  856.         LOP(O_PRINT);
  857.     }
  858.     if (strEQ(d,"printf")) {
  859.         checkcomma(s,"filehandle");
  860.         LOP(O_PRTF);
  861.     }
  862.     if (strEQ(d,"push")) {
  863.         yylval.ival = O_PUSH;
  864.         OPERATOR(PUSH);
  865.     }
  866.     if (strEQ(d,"pop"))
  867.         OPERATOR(POP);
  868.     if (strEQ(d,"pack"))
  869.         FL2(O_PACK);
  870.     if (strEQ(d,"package"))
  871.         OPERATOR(PACKAGE);
  872.     break;
  873.     case 'q': case 'Q':
  874.     SNARFWORD;
  875.     if (strEQ(d,"q")) {
  876.         s = scanstr(s-1);
  877.         TERM(RSTRING);
  878.     }
  879.     if (strEQ(d,"qq")) {
  880.         s = scanstr(s-2);
  881.         TERM(RSTRING);
  882.     }
  883.     break;
  884.     case 'r': case 'R':
  885.     SNARFWORD;
  886.     if (strEQ(d,"return"))
  887.         OLDLOP(O_RETURN);
  888.     if (strEQ(d,"require")) {
  889.         allstabs = TRUE;        /* must initialize everything since */
  890.         UNI(O_REQUIRE);        /* we don't know what will be used */
  891.     }
  892.     if (strEQ(d,"reset"))
  893.         UNI(O_RESET);
  894.     if (strEQ(d,"redo"))
  895.         LOOPX(O_REDO);
  896.     if (strEQ(d,"rename"))
  897.         FUN2(O_RENAME);
  898.     if (strEQ(d,"rand"))
  899.         UNI(O_RAND);
  900.     if (strEQ(d,"rmdir"))
  901.         UNI(O_RMDIR);
  902.     if (strEQ(d,"rindex"))
  903.         FUN2x(O_RINDEX);
  904.     if (strEQ(d,"read"))
  905.         FOP3(O_READ);
  906.     if (strEQ(d,"readdir"))
  907.         FOP(O_READDIR);
  908.     if (strEQ(d,"rewinddir"))
  909.         FOP(O_REWINDDIR);
  910.     if (strEQ(d,"reverse"))
  911.         LOP(O_REVERSE);
  912.     break;
  913.     case 's': case 'S':
  914.     if (s[1] == '\'') {
  915.         d = "s";
  916.         s++;
  917.     }
  918.     else {
  919.         SNARFWORD;
  920.     }
  921.     if (strEQ(d,"s")) {
  922.         s = scansubst(s);
  923.         if (yylval.arg)
  924.         TERM(SUBST);
  925.         else
  926.         RETURN(1);    /* force error */
  927.     }
  928.     switch (d[1]) {
  929.     case 'a':
  930.     case 'b':
  931.         break;
  932.     case 'c':
  933.         if (strEQ(d,"scalar"))
  934.         UNI(O_SCALAR);
  935.         break;
  936.     case 'd':
  937.         break;
  938.     case 'e':
  939.         if (strEQ(d,"select"))
  940.         OPERATOR(SSELECT);
  941.         if (strEQ(d,"seek"))
  942.         FOP3(O_SEEK);
  943.         if (strEQ(d,"seekdir"))
  944.         FOP2(O_SEEKDIR);
  945.         break;
  946.     case 'f':
  947.     case 'g':
  948.         break;
  949.     case 'h':
  950.         if (strEQ(d,"shift"))
  951.         TERM(SHIFT);
  952.         break;
  953.     case 'i':
  954.         if (strEQ(d,"sin"))
  955.         UNI(O_SIN);
  956.         break;
  957.     case 'j':
  958.     case 'k':
  959.         break;
  960.     case 'l':
  961.         if (strEQ(d,"sleep"))
  962.         UNI(O_SLEEP);
  963.         break;
  964.     case 'm':
  965.     case 'n':
  966.         break;
  967.     case 'o':
  968.         if (strEQ(d,"sort")) {
  969.         checkcomma(s,"subroutine name");
  970.         d = bufend;
  971.         while (s < d && isascii(*s) && isspace(*s)) s++;
  972.         if (*s == ';' || *s == ')')        /* probably a close */
  973.             fatal("sort is now a reserved word");
  974.         if (isascii(*s) && (isalpha(*s) || *s == '_')) {
  975.             for (d = s; isalpha(*d) || isdigit(*d) || *d == '_'; d++) ;
  976.             strncpy(tokenbuf,s,d-s);
  977.             if (strNE(tokenbuf,"keys") &&
  978.             strNE(tokenbuf,"values") &&
  979.             strNE(tokenbuf,"split") &&
  980.             strNE(tokenbuf,"grep") &&
  981.             strNE(tokenbuf,"readdir") &&
  982.             strNE(tokenbuf,"unpack") &&
  983.             strNE(tokenbuf,"do") &&
  984.             (d >= bufend || isspace(*d)) )
  985.             *(--s) = '\\';    /* force next ident to WORD */
  986.         }
  987.         LOP(O_SORT);
  988.         }
  989.         break;
  990.     case 'p':
  991.         if (strEQ(d,"split"))
  992.         TERM(SPLIT);
  993.         if (strEQ(d,"sprintf"))
  994.         FL(O_SPRINTF);
  995.         if (strEQ(d,"splice")) {
  996.         yylval.ival = O_SPLICE;
  997.         OPERATOR(PUSH);
  998.         }
  999.         break;
  1000.     case 'q':
  1001.         if (strEQ(d,"sqrt"))
  1002.         UNI(O_SQRT);
  1003.         break;
  1004.     case 'r':
  1005.         if (strEQ(d,"srand"))
  1006.         UNI(O_SRAND);
  1007.         break;
  1008.     case 's':
  1009.         break;
  1010.     case 't':
  1011.         if (strEQ(d,"stat"))
  1012.         FOP(O_STAT);
  1013.         if (strEQ(d,"study")) {
  1014.         sawstudy++;
  1015.         LFUN(O_STUDY);
  1016.         }
  1017.         break;
  1018.     case 'u':
  1019.         if (strEQ(d,"substr"))
  1020.         FUN2x(O_SUBSTR);
  1021.         if (strEQ(d,"sub")) {
  1022.         subline = curcmd->c_line;
  1023.         d = bufend;
  1024.         while (s < d && isspace(*s))
  1025.             s++;
  1026.         if (isalpha(*s) || *s == '_' || *s == '\'') {
  1027.             if (perldb) {
  1028.             str_sset(subname,curstname);
  1029.             str_ncat(subname,"'",1);
  1030.             for (d = s+1;
  1031.               isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\'';
  1032.               d++);
  1033.             if (d[-1] == '\'')
  1034.                 d--;
  1035.             str_ncat(subname,s,d-s);
  1036.             }
  1037.             *(--s) = '\\';    /* force next ident to WORD */
  1038.         }
  1039.         else if (perldb)
  1040.             str_set(subname,"?");
  1041.         OPERATOR(SUB);
  1042.         }
  1043.         break;
  1044.     case 'v':
  1045.     case 'w':
  1046.     case 'x':
  1047.         break;
  1048.     case 'y':
  1049.         if (strEQ(d,"system"))
  1050.         LOP(O_SYSTEM);
  1051.         if (strEQ(d,"syscall"))
  1052.         LOP(O_SYSCALL);
  1053.         break;
  1054.     case 'z':
  1055.         break;
  1056.     }
  1057.     break;
  1058.     case 't': case 'T':
  1059.     SNARFWORD;
  1060.     if (strEQ(d,"tr")) {
  1061.         s = scantrans(s);
  1062.         if (yylval.arg)
  1063.         TERM(TRANS);
  1064.         else
  1065.         RETURN(1);    /* force error */
  1066.     }
  1067.     if (strEQ(d,"tell"))
  1068.         FOP(O_TELL);
  1069.     if (strEQ(d,"telldir"))
  1070.         FOP(O_TELLDIR);
  1071.     if (strEQ(d,"time"))
  1072.         FUN0(O_TIME);
  1073.     if (strEQ(d,"truncate"))
  1074.         FOP2(O_TRUNCATE);
  1075.     break;
  1076.     case 'u': case 'U':
  1077.     SNARFWORD;
  1078.     if (strEQ(d,"using"))
  1079.         OPERATOR(USING);
  1080.     if (strEQ(d,"until")) {
  1081.         yylval.ival = curcmd->c_line;
  1082.         OPERATOR(UNTIL);
  1083.     }
  1084.     if (strEQ(d,"unless")) {
  1085.         yylval.ival = curcmd->c_line;
  1086.         OPERATOR(UNLESS);
  1087.     }
  1088.     if (strEQ(d,"unlink"))
  1089.         LOP(O_UNLINK);
  1090.     if (strEQ(d,"undef"))
  1091.         LFUN(O_UNDEF);
  1092.     if (strEQ(d,"unpack"))
  1093.         FUN2(O_UNPACK);
  1094.     if (strEQ(d,"unshift")) {
  1095.         yylval.ival = O_UNSHIFT;
  1096.         OPERATOR(PUSH);
  1097.     }
  1098.     break;
  1099.     case 'v': case 'V':
  1100.     SNARFWORD;
  1101.     if (strEQ(d,"values"))
  1102.         HFUN(O_VALUES);
  1103.     if (strEQ(d,"vec")) {
  1104.         sawvec = TRUE;
  1105.         FUN3(O_VEC);
  1106.     }
  1107.     break;
  1108.     case 'w': case 'W':
  1109.     SNARFWORD;
  1110.     if (strEQ(d,"while")) {
  1111.         yylval.ival = curcmd->c_line;
  1112.         OPERATOR(WHILE);
  1113.     }
  1114.     if (strEQ(d,"warn"))
  1115.         LOP(O_WARN);
  1116.     if (strEQ(d,"wantarray")) {
  1117.         yylval.arg = op_new(1);
  1118.         yylval.arg->arg_type = O_ITEM;
  1119.         yylval.arg[1].arg_type = A_WANTARRAY;
  1120.         TERM(RSTRING);
  1121.     }
  1122.     if (strEQ(d,"write"))
  1123.         FOP(O_WRITE);
  1124.     break;
  1125.     case 'x': case 'X':
  1126.     SNARFWORD;
  1127.     if (!expectterm && strEQ(d,"x"))
  1128.         MOP(O_REPEAT);
  1129.     break;
  1130.     case 'y': case 'Y':
  1131.     if (s[1] == '\'') {
  1132.         d = "y";
  1133.         s++;
  1134.     }
  1135.     else {
  1136.         SNARFWORD;
  1137.     }
  1138.     if (strEQ(d,"y")) {
  1139.         s = scantrans(s);
  1140.         TERM(TRANS);
  1141.     }
  1142.     break;
  1143.     case 'z': case 'Z':
  1144.     SNARFWORD;
  1145.     break;
  1146.     }
  1147.     yylval.cval = savestr(d);
  1148.     expectterm = FALSE;
  1149.     if (oldoldbufptr && oldoldbufptr < bufptr) {
  1150.     while (isspace(*oldoldbufptr))
  1151.         oldoldbufptr++;
  1152.     if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5))
  1153.         expectterm = TRUE;
  1154.     else if (*oldoldbufptr == 's' && strnEQ(oldoldbufptr,"sort",4))
  1155.         expectterm = TRUE;
  1156.     }
  1157.     return (CLINE, bufptr = s, (int)WORD);
  1158. }
  1159.  
  1160. void checkcomma (register char *s, char *what)
  1161. {
  1162.     char *word;
  1163.  
  1164.     if (*s == '(')
  1165.     s++;
  1166.     while (s < bufend && isascii(*s) && isspace(*s))
  1167.     s++;
  1168.     if (isascii(*s) && (isalpha(*s) || *s == '_')) {
  1169.     word = s++;
  1170.     while (isalpha(*s) || isdigit(*s) || *s == '_')
  1171.         s++;
  1172.     while (s < bufend && isspace(*s))
  1173.         s++;
  1174.     if (*s == ',') {
  1175.         *s = '\0';
  1176.         word = instr(
  1177.     "tell eof length shift cos exp int log rand sin sqrt ord wantarray",
  1178.           word);
  1179.         *s = ',';
  1180.         if (word)
  1181.         return;
  1182.         fatal("No comma allowed after %s", what);
  1183.     }
  1184.     }
  1185. }
  1186.  
  1187. char *scanreg (register char *s, register char *send, char *dest)
  1188. {
  1189.     register char *d;
  1190.     int brackets = 0;
  1191.  
  1192.     reparse = Nullch;
  1193.     s++;
  1194.     d = dest;
  1195.     if (isdigit(*s)) {
  1196.     while (isdigit(*s))
  1197.         *d++ = *s++;
  1198.     }
  1199.     else {
  1200.     while (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'')
  1201.         *d++ = *s++;
  1202.     }
  1203.     while (d > dest+1 && d[-1] == '\'')
  1204.     d--,s--;
  1205.     *d = '\0';
  1206.     d = dest;
  1207.     if (!*d) {
  1208.     *d = *s++;
  1209.     if (*d == '{' /* } */ ) {
  1210.         d = dest;
  1211.         brackets++;
  1212.         while (s < send && brackets) {
  1213.         if (!reparse && (d == dest || (*s && isascii(*s) &&
  1214.           (isalpha(*s) || isdigit(*s) || *s == '_') ))) {
  1215.             *d++ = *s++;
  1216.             continue;
  1217.         }
  1218.         else if (!reparse)
  1219.             reparse = s;
  1220.         switch (*s++) {
  1221.         /* { */
  1222.         case '}':
  1223.             brackets--;
  1224.             if (reparse && reparse == s - 1)
  1225.             reparse = Nullch;
  1226.             break;
  1227.         case '{':   /* } */
  1228.             brackets++;
  1229.             break;
  1230.         }
  1231.         }
  1232.         *d = '\0';
  1233.         d = dest;
  1234.     }
  1235.     else
  1236.         d[1] = '\0';
  1237.     }
  1238.     if (*d == '^' && !isspace(*s))
  1239.     *d = *s++ & 31;
  1240.     return s;
  1241. }
  1242.  
  1243. STR *scanconst (char *string, int len)
  1244. {
  1245.     register STR *retstr;
  1246.     register char *t;
  1247.     register char *d;
  1248.     register char *e;
  1249.  
  1250.     if (index(string,'|')) {
  1251.     return Nullstr;
  1252.     }
  1253.     retstr = Str_new(86,len);
  1254.     str_nset(retstr,string,len);
  1255.     t = str_get(retstr);
  1256.     e = t + len;
  1257.     retstr->str_u.str_useful = 100;
  1258.     for (d=t; d < e; ) {
  1259.     switch (*d) {
  1260.     case '{':
  1261.         if (isdigit(d[1]))
  1262.         e = d;
  1263.         else
  1264.         goto defchar;
  1265.         break;
  1266.     case '.': case '[': case '$': case '(': case ')': case '|': case '+':
  1267.         e = d;
  1268.         break;
  1269.     case '\\':
  1270.         if (d[1] && index("wWbB0123456789sSdD",d[1])) {
  1271.         e = d;
  1272.         break;
  1273.         }
  1274.         (void)bcopy(d+1,d,e-d);
  1275.         e--;
  1276.         switch(*d) {
  1277.         case 'n':
  1278.         *d = '\n';
  1279.         break;
  1280.         case 't':
  1281.         *d = '\t';
  1282.         break;
  1283.         case 'f':
  1284.         *d = '\f';
  1285.         break;
  1286.         case 'r':
  1287.         *d = '\r';
  1288.         break;
  1289.         }
  1290.         /* FALL THROUGH */
  1291.     default:
  1292.       defchar:
  1293.         if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') {
  1294.         e = d;
  1295.         break;
  1296.         }
  1297.         d++;
  1298.     }
  1299.     }
  1300.     if (d == t) {
  1301.     str_free(retstr);
  1302.     return Nullstr;
  1303.     }
  1304.     *d = '\0';
  1305.     retstr->str_cur = d - t;
  1306.     return retstr;
  1307. }
  1308.  
  1309. char *scanpat (register char *s)
  1310. {
  1311.     register SPAT *spat;
  1312.     register char *d;
  1313.     register char *e;
  1314.     int len;
  1315.     SPAT savespat;
  1316.     STR *str = Str_new(93,0);
  1317.  
  1318.     Newz(801,spat,1,SPAT);
  1319.     spat->spat_next = curstash->tbl_spatroot;    /* link into spat list */
  1320.     curstash->tbl_spatroot = spat;
  1321.  
  1322.     switch (*s++) {
  1323.     case 'm':
  1324.     s++;
  1325.     break;
  1326.     case '/':
  1327.     break;
  1328.     case '?':
  1329.     spat->spat_flags |= SPAT_ONCE;
  1330.     break;
  1331.     default:
  1332.     fatal("panic: scanpat");
  1333.     }
  1334.     s = str_append_till(str,s,bufend,s[-1],patleave);
  1335.     if (s >= bufend) {
  1336.     str_free(str);
  1337.     yyerror("Search pattern not terminated");
  1338.     yylval.arg = Nullarg;
  1339.     return s;
  1340.     }
  1341.     s++;
  1342.     while (*s == 'i' || *s == 'o') {
  1343.     if (*s == 'i') {
  1344.         s++;
  1345.         sawi = TRUE;
  1346.         spat->spat_flags |= SPAT_FOLD;
  1347.     }
  1348.     if (*s == 'o') {
  1349.         s++;
  1350.         spat->spat_flags |= SPAT_KEEP;
  1351.     }
  1352.     }
  1353.     len = str->str_cur;
  1354.     e = str->str_ptr + len;
  1355.     for (d = str->str_ptr; d < e; d++) {
  1356.     if (*d == '\\')
  1357.         d++;
  1358.     else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
  1359.          (*d == '@')) {
  1360.         register ARG *arg;
  1361.  
  1362.         spat->spat_runtime = arg = op_new(1);
  1363.         arg->arg_type = O_ITEM;
  1364.         arg[1].arg_type = A_DOUBLE;
  1365.         arg[1].arg_ptr.arg_str = str_smake(str);
  1366.         d = scanreg(d,bufend,buf);
  1367.         (void)stabent(buf,TRUE);        /* make sure it's created */
  1368.         for (; d < e; d++) {
  1369.         if (*d == '\\')
  1370.             d++;
  1371.         else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
  1372.             d = scanreg(d,bufend,buf);
  1373.             (void)stabent(buf,TRUE);
  1374.         }
  1375.         else if (*d == '@') {
  1376.             d = scanreg(d,bufend,buf);
  1377.             if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
  1378.               strEQ(buf,"SIG") || strEQ(buf,"INC"))
  1379.             (void)stabent(buf,TRUE);
  1380.         }
  1381.         }
  1382.         goto got_pat;        /* skip compiling for now */
  1383.     }
  1384.     }
  1385.     if (spat->spat_flags & SPAT_FOLD)
  1386. #ifdef STRUCTCOPY
  1387.     savespat = *spat;
  1388. #else
  1389.     (void)bcopy((char *)spat, (char *)&savespat, sizeof(SPAT));
  1390. #endif
  1391.     if (*str->str_ptr == '^') {
  1392.     spat->spat_short = scanconst(str->str_ptr+1,len-1);
  1393.     if (spat->spat_short) {
  1394.         spat->spat_slen = spat->spat_short->str_cur;
  1395.         if (spat->spat_slen == len - 1)
  1396.         spat->spat_flags |= SPAT_ALL;
  1397.     }
  1398.     }
  1399.     else {
  1400.     spat->spat_flags |= SPAT_SCANFIRST;
  1401.     spat->spat_short = scanconst(str->str_ptr,len);
  1402.     if (spat->spat_short) {
  1403.         spat->spat_slen = spat->spat_short->str_cur;
  1404.         if (spat->spat_slen == len)
  1405.         spat->spat_flags |= SPAT_ALL;
  1406.     }
  1407.     }    
  1408.     if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
  1409.     fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
  1410.     spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
  1411.         spat->spat_flags & SPAT_FOLD);
  1412.         /* Note that this regexp can still be used if someone says
  1413.          * something like /a/ && s//b/;  so we can't delete it.
  1414.          */
  1415.     }
  1416.     else {
  1417.     if (spat->spat_flags & SPAT_FOLD)
  1418. #ifdef STRUCTCOPY
  1419.         *spat = savespat;
  1420. #else
  1421.         (void)bcopy((char *)&savespat, (char *)spat, sizeof(SPAT));
  1422. #endif
  1423.     if (spat->spat_short)
  1424.         fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
  1425.     spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
  1426.         spat->spat_flags & SPAT_FOLD);
  1427.     hoistmust(spat);
  1428.     }
  1429.   got_pat:
  1430.     str_free(str);
  1431.     yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat);
  1432.     return s;
  1433. }
  1434.  
  1435. char *scansubst (register char *s)
  1436. {
  1437.     register SPAT *spat;
  1438.     register char *d;
  1439.     register char *e;
  1440.     int len;
  1441.     STR *str = Str_new(93,0);
  1442.  
  1443.     Newz(802,spat,1,SPAT);
  1444.     spat->spat_next = curstash->tbl_spatroot;    /* link into spat list */
  1445.     curstash->tbl_spatroot = spat;
  1446.  
  1447.     s = str_append_till(str,s+1,bufend,*s,patleave);
  1448.     if (s >= bufend) {
  1449.     yyerror("Substitution pattern not terminated");
  1450.     yylval.arg = Nullarg;
  1451.     return s;
  1452.     }
  1453.     len = str->str_cur;
  1454.     e = str->str_ptr + len;
  1455.     for (d = str->str_ptr; d < e; d++) {
  1456.     if (*d == '\\')
  1457.         d++;
  1458.     else if ((*d == '$' && d[1] && d[1] != '|' && /*(*/ d[1] != ')') ||
  1459.         *d == '@' ) {
  1460.         register ARG *arg;
  1461.  
  1462.         spat->spat_runtime = arg = op_new(1);
  1463.         arg->arg_type = O_ITEM;
  1464.         arg[1].arg_type = A_DOUBLE;
  1465.         arg[1].arg_ptr.arg_str = str_smake(str);
  1466.         d = scanreg(d,bufend,buf);
  1467.         (void)stabent(buf,TRUE);        /* make sure it's created */
  1468.         for (; *d; d++) {
  1469.         if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
  1470.             d = scanreg(d,bufend,buf);
  1471.             (void)stabent(buf,TRUE);
  1472.         }
  1473.         else if (*d == '@' && d[-1] != '\\') {
  1474.             d = scanreg(d,bufend,buf);
  1475.             if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
  1476.               strEQ(buf,"SIG") || strEQ(buf,"INC"))
  1477.             (void)stabent(buf,TRUE);
  1478.         }
  1479.         }
  1480.         goto get_repl;        /* skip compiling for now */
  1481.     }
  1482.     }
  1483.     if (*str->str_ptr == '^') {
  1484.     spat->spat_short = scanconst(str->str_ptr+1,len-1);
  1485.     if (spat->spat_short)
  1486.         spat->spat_slen = spat->spat_short->str_cur;
  1487.     }
  1488.     else {
  1489.     spat->spat_flags |= SPAT_SCANFIRST;
  1490.     spat->spat_short = scanconst(str->str_ptr,len);
  1491.     if (spat->spat_short)
  1492.         spat->spat_slen = spat->spat_short->str_cur;
  1493.     }
  1494. get_repl:
  1495.     s = scanstr(s);
  1496.     if (s >= bufend) {
  1497.     str_free(str);
  1498.     yyerror("Substitution replacement not terminated");
  1499.     yylval.arg = Nullarg;
  1500.     return s;
  1501.     }
  1502.     spat->spat_repl = yylval.arg;
  1503.     spat->spat_flags |= SPAT_ONCE;
  1504.     if ((spat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
  1505.     spat->spat_flags |= SPAT_CONST;
  1506.     else if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) {
  1507.     STR *tmpstr;
  1508.     register char *t;
  1509.  
  1510.     spat->spat_flags |= SPAT_CONST;
  1511.     tmpstr = spat->spat_repl[1].arg_ptr.arg_str;
  1512.     e = tmpstr->str_ptr + tmpstr->str_cur;
  1513.     for (t = tmpstr->str_ptr; t < e; t++) {
  1514.         if (*t == '$' && t[1] && (index("`'&+0123456789",t[1]) ||
  1515.           (t[1] == '{' /*}*/ && isdigit(t[2])) ))
  1516.         spat->spat_flags &= ~SPAT_CONST;
  1517.     }
  1518.     }
  1519.     while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') {
  1520.     if (*s == 'e') {
  1521.         s++;
  1522.         if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE)
  1523.         spat->spat_repl[1].arg_type = A_SINGLE;
  1524.         spat->spat_repl = make_op(O_EVAL,2,
  1525.         spat->spat_repl,
  1526.         Nullarg,
  1527.         Nullarg);
  1528.         spat->spat_flags &= ~SPAT_CONST;
  1529.     }
  1530.     if (*s == 'g') {
  1531.         s++;
  1532.         spat->spat_flags &= ~SPAT_ONCE;
  1533.     }
  1534.     if (*s == 'i') {
  1535.         s++;
  1536.         sawi = TRUE;
  1537.         spat->spat_flags |= SPAT_FOLD;
  1538.         if (!(spat->spat_flags & SPAT_SCANFIRST)) {
  1539.         str_free(spat->spat_short);    /* anchored opt doesn't do */
  1540.         spat->spat_short = Nullstr;    /* case insensitive match */
  1541.         spat->spat_slen = 0;
  1542.         }
  1543.     }
  1544.     if (*s == 'o') {
  1545.         s++;
  1546.         spat->spat_flags |= SPAT_KEEP;
  1547.     }
  1548.     }
  1549.     if (spat->spat_short && (spat->spat_flags & SPAT_SCANFIRST))
  1550.     fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
  1551.     if (!spat->spat_runtime) {
  1552.     spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
  1553.       spat->spat_flags & SPAT_FOLD);
  1554.     hoistmust(spat);
  1555.     }
  1556.     yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
  1557.     str_free(str);
  1558.     return s;
  1559. }
  1560.  
  1561. void hoistmust (register SPAT *spat)
  1562. {
  1563.     if (spat->spat_regexp->regmust) {    /* is there a better short-circuit? */
  1564.     if (spat->spat_short &&
  1565.       str_eq(spat->spat_short,spat->spat_regexp->regmust))
  1566.     {
  1567.         if (spat->spat_flags & SPAT_SCANFIRST) {
  1568.         str_free(spat->spat_short);
  1569.         spat->spat_short = Nullstr;
  1570.         }
  1571.         else {
  1572.         str_free(spat->spat_regexp->regmust);
  1573.         spat->spat_regexp->regmust = Nullstr;
  1574.         return;
  1575.         }
  1576.     }
  1577.     if (!spat->spat_short ||    /* promote the better string */
  1578.       ((spat->spat_flags & SPAT_SCANFIRST) &&
  1579.        (spat->spat_short->str_cur < spat->spat_regexp->regmust->str_cur) )){
  1580.         str_free(spat->spat_short);        /* ok if null */
  1581.         spat->spat_short = spat->spat_regexp->regmust;
  1582.         spat->spat_regexp->regmust = Nullstr;
  1583.         spat->spat_flags |= SPAT_SCANFIRST;
  1584.     }
  1585.     }
  1586. }
  1587.  
  1588. char *expand_charset (register char *s, int len, int *retlen)
  1589. {
  1590.     char t[520];
  1591.     register char *d = t;
  1592.     register int i;
  1593.     register char *send = s + len;
  1594.  
  1595.     while (s < send && d - t <= 256) {
  1596.     if (s[1] == '-' && s+2 < send) {
  1597.         for (i = s[0]; i <= s[2]; i++)
  1598.         *d++ = i;
  1599.         s += 3;
  1600.     }
  1601.     else
  1602.         *d++ = *s++;
  1603.     }
  1604.     *d = '\0';
  1605.     *retlen = d - t;
  1606.     return nsavestr(t,d-t);
  1607. }
  1608.  
  1609. char *scantrans (register char *s)
  1610. {
  1611.     ARG *arg =
  1612.     l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg));
  1613.     register char *t;
  1614.     register char *r;
  1615.     register short *tbl;
  1616.     register int i;
  1617.     register int j;
  1618.     int tlen, rlen;
  1619.     int squash;
  1620.     int delete;
  1621.     int complement;
  1622.  
  1623.     Newz(803,tbl,256,short);
  1624.     arg[2].arg_type = A_NULL;
  1625.     arg[2].arg_ptr.arg_cval = (char*) tbl;
  1626.     s = scanstr(s);
  1627.     if (s >= bufend) {
  1628.     yyerror("Translation pattern not terminated");
  1629.     yylval.arg = Nullarg;
  1630.     return s;
  1631.     }
  1632.     t = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
  1633.     yylval.arg[1].arg_ptr.arg_str->str_cur,&tlen);
  1634.     free_arg(yylval.arg);
  1635.     s = scanstr(s-1);
  1636.     if (s >= bufend) {
  1637.     yyerror("Translation replacement not terminated");
  1638.     yylval.arg = Nullarg;
  1639.     return s;
  1640.     }
  1641.     complement = delete = squash = 0;
  1642.     while (*s == 'c' || *s == 'd' || *s == 's') {
  1643.     if (*s == 'c')
  1644.         complement = 1;
  1645.     else if (*s == 'd')
  1646.         delete = 2;
  1647.     else
  1648.         squash = 1;
  1649.     s++;
  1650.     }
  1651.     r = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
  1652.     yylval.arg[1].arg_ptr.arg_str->str_cur,&rlen);
  1653.     free_arg(yylval.arg);
  1654.     arg[2].arg_len = delete|squash;
  1655.     yylval.arg = arg;
  1656.     if (!rlen && !delete) {
  1657.     Safefree(r);
  1658.     r = t; rlen = tlen;
  1659.     }
  1660.     if (complement) {
  1661.     Zero(tbl, 256, short);
  1662.     for (i = 0; i < tlen; i++)
  1663.         tbl[t[i] & 0377] = -1;
  1664.     for (i = 0, j = 0; i < 256; i++,j++) {
  1665.         if (!tbl[i]) {
  1666.         if (j >= rlen) {
  1667.             if (delete) {
  1668.             tbl[i] = -2;
  1669.             continue;
  1670.             }
  1671.             --j;
  1672.         }
  1673.         tbl[i] = r[j];
  1674.         }
  1675.     }
  1676.     }
  1677.     else {
  1678.     for (i = 0; i < 256; i++)
  1679.         tbl[i] = -1;
  1680.     for (i = 0, j = 0; i < tlen; i++,j++) {
  1681.         if (j >= rlen) {
  1682.         if (delete) {
  1683.             if (tbl[t[i] & 0377] == -1)
  1684.             tbl[t[i] & 0377] = -2;
  1685.             continue;
  1686.         }
  1687.         --j;
  1688.         }
  1689.         if (tbl[t[i] & 0377] == -1)
  1690.         tbl[t[i] & 0377] = r[j] & 0377;
  1691.     }
  1692.     }
  1693.     if (r != t)
  1694.     Safefree(r);
  1695.     Safefree(t);
  1696.     return s;
  1697. }
  1698.  
  1699. char *scanstr (register char *s)
  1700. {
  1701.     register char term;
  1702.     register char *d;
  1703.     register ARG *arg;
  1704.     register char *send;
  1705.     register bool makesingle = FALSE;
  1706.     register STAB *stab;
  1707.     bool alwaysdollar = FALSE;
  1708.     bool hereis = FALSE;
  1709.     STR *herewas;
  1710.     STR *str;
  1711.     char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
  1712.     int len;
  1713.  
  1714.     arg = op_new(1);
  1715.     yylval.arg = arg;
  1716.     arg->arg_type = O_ITEM;
  1717.  
  1718.     switch (*s) {
  1719.     default:            /* a substitution replacement */
  1720.     arg[1].arg_type = A_DOUBLE;
  1721.     makesingle = TRUE;    /* maybe disable runtime scanning */
  1722.     term = *s;
  1723.     if (term == '\'')
  1724.         leave = Nullch;
  1725.     goto snarf_it;
  1726.     case '0':
  1727.     {
  1728.         unsigned long i;
  1729.         int shift;
  1730.  
  1731.         arg[1].arg_type = A_SINGLE;
  1732.         if (s[1] == 'x') {
  1733.         shift = 4;
  1734.         s += 2;
  1735.         }
  1736.         else if (s[1] == '.')
  1737.         goto decimal;
  1738.         else
  1739.         shift = 3;
  1740.         i = 0;
  1741.         for (;;) {
  1742.         switch (*s) {
  1743.         default:
  1744.             goto out;
  1745.         case '8': case '9':
  1746.             if (shift != 4)
  1747.             yyerror("Illegal octal digit");
  1748.             /* FALL THROUGH */
  1749.         case '0': case '1': case '2': case '3': case '4':
  1750.         case '5': case '6': case '7':
  1751.             i <<= shift;
  1752.             i += *s++ & 15L;
  1753.             break;
  1754.         case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
  1755.         case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
  1756.             if (shift != 4)
  1757.             goto out;
  1758.             i <<= 4;
  1759.             i += (*s++ & 7L) + 9L;
  1760.             break;
  1761.         }
  1762.         }
  1763.       out:
  1764.         str = Str_new(92,0);
  1765.         str_numset(str,(double)i);
  1766.         if (str->str_ptr) {
  1767.         Safefree(str->str_ptr);
  1768.         str->str_ptr = Nullch;
  1769.         str->str_len = str->str_cur = 0;
  1770.         }
  1771.         arg[1].arg_ptr.arg_str = str;
  1772.     }
  1773.     break;
  1774.     case '1': case '2': case '3': case '4': case '5':
  1775.     case '6': case '7': case '8': case '9': case '.':
  1776.       decimal:
  1777.     arg[1].arg_type = A_SINGLE;
  1778.     d = tokenbuf;
  1779.     while (isdigit(*s) || *s == '_') {
  1780.         if (*s == '_')
  1781.         s++;
  1782.         else
  1783.         *d++ = *s++;
  1784.     }
  1785.     if (*s == '.' && s[1] && index("0123456789eE ;",s[1])) {
  1786.         *d++ = *s++;
  1787.         while (isdigit(*s) || *s == '_') {
  1788.         if (*s == '_')
  1789.             s++;
  1790.         else
  1791.             *d++ = *s++;
  1792.         }
  1793.     }
  1794.     if (*s && index("eE",*s) && index("+-0123456789",s[1])) {
  1795.         *d++ = *s++;
  1796.         if (*s == '+' || *s == '-')
  1797.         *d++ = *s++;
  1798.         while (isdigit(*s))
  1799.         *d++ = *s++;
  1800.     }
  1801.     *d = '\0';
  1802.     str = Str_new(92,0);
  1803.     str_numset(str,atof(tokenbuf));
  1804.     if (str->str_ptr) {
  1805.         Safefree(str->str_ptr);
  1806.         str->str_ptr = Nullch;
  1807.         str->str_len = str->str_cur = 0;
  1808.     }
  1809.     arg[1].arg_ptr.arg_str = str;
  1810.     break;
  1811.     case '<':
  1812.     if (*++s == '<') {
  1813.         hereis = TRUE;
  1814.         d = tokenbuf;
  1815.         if (!rsfp)
  1816.         *d++ = '\n';
  1817.         if (*++s && index("`'\"",*s)) {
  1818.         term = *s++;
  1819.         s = cpytill(d,s,bufend,term,&len);
  1820.         if (s < bufend)
  1821.             s++;
  1822.         d += len;
  1823.         }
  1824.         else {
  1825.         if (*s == '\\')
  1826.             s++, term = '\'';
  1827.         else
  1828.             term = '"';
  1829.         while (isascii(*s) && (isalpha(*s) || isdigit(*s) || *s == '_'))
  1830.             *d++ = *s++;
  1831.         }                /* assuming tokenbuf won't clobber */
  1832.         *d++ = '\n';
  1833.         *d = '\0';
  1834.         len = d - tokenbuf;
  1835.         d = "\n";
  1836.         if (rsfp || (d=ninstr(s,bufend,d,d+1)) == Nullch)
  1837.         herewas = str_make(s,bufend-s);
  1838.         else
  1839.         s--, herewas = str_make(s,d-s);
  1840.         s += herewas->str_cur;
  1841.         if (term == '\'')
  1842.         goto do_single;
  1843.         if (term == '`')
  1844.         goto do_back;
  1845.         goto do_double;
  1846.     }
  1847.     d = tokenbuf;
  1848.     s = cpytill(d,s,bufend,'>',&len);
  1849.     if (s < bufend)
  1850.         s++;
  1851.     if (*d == '$') d++;
  1852.     while (*d &&
  1853.       (isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\''))
  1854.         d++;
  1855.     if (d - tokenbuf != len) {
  1856.         d = tokenbuf;
  1857.         arg[1].arg_type = A_GLOB;
  1858.         d = nsavestr(d,len);
  1859.         arg[1].arg_ptr.arg_stab = stab = genstab();
  1860.         stab_io(stab) = stio_new();
  1861.         stab_val(stab) = str_make(d,len);
  1862.         Safefree(d);
  1863.     }
  1864.     else {
  1865.         d = tokenbuf;
  1866.         if (!len)
  1867.         (void)strcpy(d,"ARGV");
  1868.         if (*d == '$') {
  1869.         arg[1].arg_type = A_INDREAD;
  1870.         arg[1].arg_ptr.arg_stab = stabent(d+1,TRUE);
  1871.         }
  1872.         else {
  1873.         arg[1].arg_type = A_READ;
  1874.         arg[1].arg_ptr.arg_stab = stabent(d,TRUE);
  1875.         if (!stab_io(arg[1].arg_ptr.arg_stab))
  1876.             stab_io(arg[1].arg_ptr.arg_stab) = stio_new();
  1877.         if (strEQ(d,"ARGV")) {
  1878.             (void)aadd(arg[1].arg_ptr.arg_stab);
  1879.             stab_io(arg[1].arg_ptr.arg_stab)->flags |=
  1880.               IOF_ARGV|IOF_START;
  1881.         }
  1882.         }
  1883.     }
  1884.     break;
  1885.  
  1886.     case 'q':
  1887.     s++;
  1888.     if (*s == 'q') {
  1889.         s++;
  1890.         goto do_double;
  1891.     }
  1892.     /* FALL THROUGH */
  1893.     case '\'':
  1894.       do_single:
  1895.     term = *s;
  1896.     arg[1].arg_type = A_SINGLE;
  1897.     leave = Nullch;
  1898.     goto snarf_it;
  1899.  
  1900.     case '"': 
  1901.       do_double:
  1902.     term = *s;
  1903.     arg[1].arg_type = A_DOUBLE;
  1904.     makesingle = TRUE;    /* maybe disable runtime scanning */
  1905.     alwaysdollar = TRUE;    /* treat $) and $| as variables */
  1906.     goto snarf_it;
  1907.     case '`':
  1908.       do_back:
  1909.     term = *s;
  1910.     arg[1].arg_type = A_BACKTICK;
  1911.     alwaysdollar = TRUE;    /* treat $) and $| as variables */
  1912.       snarf_it:
  1913.     {
  1914.         STR *tmpstr;
  1915.         char *tmps;
  1916.  
  1917.         multi_start = curcmd->c_line;
  1918.         if (hereis)
  1919.         multi_open = multi_close = '<';
  1920.         else {
  1921.         multi_open = term;
  1922.         if (term && (tmps = index("([{< )]}> )]}>",term)) != Nullch)
  1923.             term = tmps[5];
  1924.         multi_close = term;
  1925.         }
  1926.         tmpstr = Str_new(87,80);
  1927.         if (hereis) {
  1928.         term = *tokenbuf;
  1929.         if (!rsfp) {
  1930.             d = s;
  1931.             while (s < bufend &&
  1932.               (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
  1933.             if (*s++ == '\n')
  1934.                 curcmd->c_line++;
  1935.             }
  1936.             if (s >= bufend) {
  1937.             curcmd->c_line = multi_start;
  1938.             fatal("EOF in string");
  1939.             }
  1940.             str_nset(tmpstr,d+1,s-d);
  1941.             s += len - 1;
  1942.             str_ncat(herewas,s,bufend-s);
  1943.             str_replace(linestr,herewas);
  1944.             oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr);
  1945.             bufend = linestr->str_ptr + linestr->str_cur;
  1946.             hereis = FALSE;
  1947.         }
  1948.         else
  1949.             str_nset(tmpstr,"",0);   /* avoid "uninitialized" warning */
  1950.         }
  1951.         else
  1952.         s = str_append_till(tmpstr,s+1,bufend,term,leave);
  1953.         while (s >= bufend) {    /* multiple line string? */
  1954.         if (!rsfp ||
  1955.          (oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0)) == Nullch) {
  1956.             curcmd->c_line = multi_start;
  1957.             fatal("EOF in string");
  1958.         }
  1959.         curcmd->c_line++;
  1960.         if (perldb) {
  1961.             STR *str = Str_new(88,0);
  1962.  
  1963.             str_sset(str,linestr);
  1964.             astore(stab_xarray(curcmd->c_filestab),
  1965.               (int)curcmd->c_line,str);
  1966.         }
  1967.         bufend = linestr->str_ptr + linestr->str_cur;
  1968.         if (hereis) {
  1969.             if (*s == term && bcmp(s,tokenbuf,len) == 0) {
  1970.             s = bufend - 1;
  1971.             *s = ' ';
  1972.             str_scat(linestr,herewas);
  1973.             bufend = linestr->str_ptr + linestr->str_cur;
  1974.             }
  1975.             else {
  1976.             s = bufend;
  1977.             str_scat(tmpstr,linestr);
  1978.             }
  1979.         }
  1980.         else
  1981.             s = str_append_till(tmpstr,s,bufend,term,leave);
  1982.         }
  1983.         multi_end = curcmd->c_line;
  1984.         s++;
  1985.         if (tmpstr->str_cur + 5 < tmpstr->str_len) {
  1986.         tmpstr->str_len = tmpstr->str_cur + 1;
  1987.         Renew(tmpstr->str_ptr, tmpstr->str_len, char);
  1988.         }
  1989.         if ((arg[1].arg_type & A_MASK) == A_SINGLE) {
  1990.         arg[1].arg_ptr.arg_str = tmpstr;
  1991.         break;
  1992.         }
  1993.         tmps = s;
  1994.         s = tmpstr->str_ptr;
  1995.         send = s + tmpstr->str_cur;
  1996.         while (s < send) {        /* see if we can make SINGLE */
  1997.         if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
  1998.           !alwaysdollar && s[1] != '0')
  1999.             *s = '$';        /* grandfather \digit in subst */
  2000.         if ((*s == '$' || *s == '@') && s+1 < send &&
  2001.           (alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
  2002.             makesingle = FALSE;    /* force interpretation */
  2003.         }
  2004.         else if (*s == '\\' && s+1 < send) {
  2005.             s++;
  2006.         }
  2007.         s++;
  2008.         }
  2009.         s = d = tmpstr->str_ptr;    /* assuming shrinkage only */
  2010.         while (s < send) {
  2011.         if ((*s == '$' && s+1 < send &&
  2012.             (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
  2013.             (*s == '@' && s+1 < send) ) {
  2014.             len = scanreg(s,send,tokenbuf) - s;
  2015.             if (*s == '$' || strEQ(tokenbuf,"ARGV")
  2016.               || strEQ(tokenbuf,"ENV")
  2017.               || strEQ(tokenbuf,"SIG")
  2018.               || strEQ(tokenbuf,"INC") )
  2019.             (void)stabent(tokenbuf,TRUE); /* make sure it exists */
  2020.             while (len--)
  2021.             *d++ = *s++;
  2022.             continue;
  2023.         }
  2024.         else if (*s == '\\' && s+1 < send) {
  2025.             s++;
  2026.             switch (*s) {
  2027.             default:
  2028.             if (!makesingle && (!leave || (*s && index(leave,*s))))
  2029.                 *d++ = '\\';
  2030.             *d++ = *s++;
  2031.             continue;
  2032.             case '0': case '1': case '2': case '3':
  2033.             case '4': case '5': case '6': case '7':
  2034.             *d = *s++ - '0';
  2035.             if (s < send && *s && index("01234567",*s)) {
  2036.                 *d <<= 3;
  2037.                 *d += *s++ - '0';
  2038.             }
  2039.             if (s < send && *s && index("01234567",*s)) {
  2040.                 *d <<= 3;
  2041.                 *d += *s++ - '0';
  2042.             }
  2043.             d++;
  2044.             continue;
  2045.             case 'b':
  2046.             *d++ = '\b';
  2047.             break;
  2048.             case 'n':
  2049.             *d++ = '\n';
  2050.             break;
  2051.             case 'r':
  2052.             *d++ = '\r';
  2053.             break;
  2054.             case 'f':
  2055.             *d++ = '\f';
  2056.             break;
  2057.             case 't':
  2058.             *d++ = '\t';
  2059.             break;
  2060.             }
  2061.             s++;
  2062.             continue;
  2063.         }
  2064.         *d++ = *s++;
  2065.         }
  2066.         *d = '\0';
  2067.  
  2068.         if ((arg[1].arg_type & A_MASK) == A_DOUBLE && makesingle)
  2069.             arg[1].arg_type = A_SINGLE;    /* now we can optimize on it */
  2070.  
  2071.         tmpstr->str_cur = d - tmpstr->str_ptr;
  2072.         arg[1].arg_ptr.arg_str = tmpstr;
  2073.         s = tmps;
  2074.         break;
  2075.     }
  2076.     }
  2077.     if (hereis)
  2078.     str_free(herewas);
  2079.     return s;
  2080. }
  2081.  
  2082. FCMD *load_format (void)
  2083. {
  2084.     FCMD froot;
  2085.     FCMD *flinebeg;
  2086.     char *eol;
  2087.     register FCMD *fprev = &froot;
  2088.     register FCMD *fcmd;
  2089.     register char *s;
  2090.     register char *t;
  2091.     register STR *str;
  2092.     bool noblank;
  2093.     bool repeater;
  2094.  
  2095.     Zero(&froot, 1, FCMD);
  2096.     s = bufptr;
  2097.     while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
  2098.     curcmd->c_line++;
  2099.     if (in_eval && !rsfp) {
  2100.         eol = index(s,'\n');
  2101.         if (!eol++)
  2102.         eol = bufend;
  2103.     }
  2104.     else
  2105.         eol = bufend = linestr->str_ptr + linestr->str_cur;
  2106.     if (perldb) {
  2107.         STR *tmpstr = Str_new(89,0);
  2108.  
  2109.         str_nset(tmpstr, s, eol-s);
  2110.         astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
  2111.     }
  2112.     if (*s == '.') {
  2113.         for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
  2114.         if (*t == '\n') {
  2115.         bufptr = s;
  2116.         return froot.f_next;
  2117.         }
  2118.     }
  2119.     if (*s == '#') {
  2120.         s = eol;
  2121.         continue;
  2122.     }
  2123.     flinebeg = Nullfcmd;
  2124.     noblank = FALSE;
  2125.     repeater = FALSE;
  2126.     while (s < eol) {
  2127.         Newz(804,fcmd,1,FCMD);
  2128.         fprev->f_next = fcmd;
  2129.         fprev = fcmd;
  2130.         for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
  2131.         if (*t == '~') {
  2132.             noblank = TRUE;
  2133.             *t = ' ';
  2134.             if (t[1] == '~') {
  2135.             repeater = TRUE;
  2136.             t[1] = ' ';
  2137.             }
  2138.         }
  2139.         }
  2140.         fcmd->f_pre = nsavestr(s, t-s);
  2141.         fcmd->f_presize = t-s;
  2142.         s = t;
  2143.         if (s >= eol) {
  2144.         if (noblank)
  2145.             fcmd->f_flags |= FC_NOBLANK;
  2146.         if (repeater)
  2147.             fcmd->f_flags |= FC_REPEAT;
  2148.         break;
  2149.         }
  2150.         if (!flinebeg)
  2151.         flinebeg = fcmd;        /* start values here */
  2152.         if (*s++ == '^')
  2153.         fcmd->f_flags |= FC_CHOP;    /* for doing text filling */
  2154.         switch (*s) {
  2155.         case '*':
  2156.         fcmd->f_type = F_LINES;
  2157.         *s = '\0';
  2158.         break;
  2159.         case '<':
  2160.         fcmd->f_type = F_LEFT;
  2161.         while (*s == '<')
  2162.             s++;
  2163.         break;
  2164.         case '>':
  2165.         fcmd->f_type = F_RIGHT;
  2166.         while (*s == '>')
  2167.             s++;
  2168.         break;
  2169.         case '|':
  2170.         fcmd->f_type = F_CENTER;
  2171.         while (*s == '|')
  2172.             s++;
  2173.         break;
  2174.         case '#':
  2175.         case '.':
  2176.         /* Catch the special case @... and handle it as a string
  2177.            field. */
  2178.         if (*s == '.' && s[1] == '.') {
  2179.             goto default_format;
  2180.         }
  2181.         fcmd->f_type = F_DECIMAL;
  2182.         {
  2183.             char *p;
  2184.  
  2185.             /* Read a format in the form @####.####, where either group
  2186.                of ### may be empty, or the final .### may be missing. */
  2187.             while (*s == '#')
  2188.             s++;
  2189.             if (*s == '.') {
  2190.             s++;
  2191.             p = s;
  2192.             while (*s == '#')
  2193.                 s++;
  2194.             fcmd->f_decimals = s-p;
  2195.             fcmd->f_flags |= FC_DP;
  2196.             } else {
  2197.             fcmd->f_decimals = 0;
  2198.             }
  2199.         }
  2200.         break;
  2201.         default:
  2202.         default_format:
  2203.         fcmd->f_type = F_LEFT;
  2204.         break;
  2205.         }
  2206.         if (fcmd->f_flags & FC_CHOP && *s == '.') {
  2207.         fcmd->f_flags |= FC_MORE;
  2208.         while (*s == '.')
  2209.             s++;
  2210.         }
  2211.         fcmd->f_size = s-t;
  2212.     }
  2213.     if (flinebeg) {
  2214.       again:
  2215.         if (s >= bufend &&
  2216.           (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
  2217.         goto badform;
  2218.         curcmd->c_line++;
  2219.         if (in_eval && !rsfp) {
  2220.         eol = index(s,'\n');
  2221.         if (!eol++)
  2222.             eol = bufend;
  2223.         }
  2224.         else
  2225.         eol = bufend = linestr->str_ptr + linestr->str_cur;
  2226.         if (perldb) {
  2227.         STR *tmpstr = Str_new(90,0);
  2228.  
  2229.         str_nset(tmpstr, s, eol-s);
  2230.         astore(stab_xarray(curcmd->c_filestab),
  2231.             (int)curcmd->c_line,tmpstr);
  2232.         }
  2233.         if (strnEQ(s,".\n",2)) {
  2234.         bufptr = s;
  2235.         yyerror("Missing values line");
  2236.         return froot.f_next;
  2237.         }
  2238.         if (*s == '#') {
  2239.         s = eol;
  2240.         goto again;
  2241.         }
  2242.         str = flinebeg->f_unparsed = Str_new(91,eol - s);
  2243.         str->str_u.str_hash = curstash;
  2244.         str_nset(str,"(",1);
  2245.         flinebeg->f_line = curcmd->c_line;
  2246.         eol[-1] = '\0';
  2247.         if (!flinebeg->f_next->f_type || index(s, ',')) {
  2248.         eol[-1] = '\n';
  2249.         str_ncat(str, s, eol - s - 1);
  2250.         str_ncat(str,",$$);",5);
  2251.         s = eol;
  2252.         }
  2253.         else {
  2254.         eol[-1] = '\n';
  2255.         while (s < eol && isspace(*s))
  2256.             s++;
  2257.         t = s;
  2258.         while (s < eol) {
  2259.             switch (*s) {
  2260.             case ' ': case '\t': case '\n': case ';':
  2261.             str_ncat(str, t, s - t);
  2262.             str_ncat(str, "," ,1);
  2263.             while (s < eol && (isspace(*s) || *s == ';'))
  2264.                 s++;
  2265.             t = s;
  2266.             break;
  2267.             case '$':
  2268.             str_ncat(str, t, s - t);
  2269.             t = s;
  2270.             s = scanreg(s,eol,tokenbuf);
  2271.             str_ncat(str, t, s - t);
  2272.             t = s;
  2273.             if (s < eol && *s && index("$'\"",*s))
  2274.                 str_ncat(str, ",", 1);
  2275.             break;
  2276.             case '"': case '\'':
  2277.             str_ncat(str, t, s - t);
  2278.             t = s;
  2279.             s++;
  2280.             while (s < eol && (*s != *t || s[-1] == '\\'))
  2281.                 s++;
  2282.             if (s < eol)
  2283.                 s++;
  2284.             str_ncat(str, t, s - t);
  2285.             t = s;
  2286.             if (s < eol && *s && index("$'\"",*s))
  2287.                 str_ncat(str, ",", 1);
  2288.             break;
  2289.             default:
  2290.             yyerror("Please use commas to separate fields");
  2291.             }
  2292.         }
  2293.         str_ncat(str,"$$);",4);
  2294.         }
  2295.     }
  2296.     }
  2297.   badform:
  2298.     bufptr = str_get(linestr);
  2299.     yyerror("Format not terminated");
  2300.     return froot.f_next;
  2301. }
  2302.