home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / src / streams.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-19  |  24.5 KB  |  1,089 lines
  1. /* streams.c -- Lisp stream handling
  2.    Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. This file is part of Jade.
  5.  
  6. Jade is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. Jade is distributed in the hope that it will be useful, but
  12. WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with Jade; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /*
  21.  * These are the Lisp objects which are classed as streams:
  22.  *
  23.  * file: (rw)
  24.  * mark: (rw), advance pos attribute of mark afterwards
  25.  * buffer: (rw), from cursor pos
  26.  * (number . string): (r), from the number'th char of string
  27.  * (string . ??): (w), to end of string
  28.  * (buffer . pos): (rw), from buffer, pos is advanced
  29.  * (buffer . t): (w), end of buffer
  30.  * function-name: (rw), call function, when reading function is expected to
  31.  *          return the next character, when writing it is called with
  32.  *          one arg, either character or string.
  33.  * process: (w), write to the stdin of the process if it's running
  34.  * t: (w), display in status line
  35.  */
  36.  
  37. #include "jade.h"
  38. #include "jade_protos.h"
  39. #include "regexp/regexp.h"
  40.  
  41. #include <string.h>
  42. #include <fcntl.h>
  43. #include <ctype.h>
  44. #include <stdlib.h>
  45.  
  46. _PR int streamgetc(VALUE);
  47. _PR int streamungetc(VALUE, int);
  48. _PR int streamputc(VALUE, int);
  49. _PR int streamputs(VALUE, u_char *, int);
  50. _PR u_char escstreamchar(VALUE, int *);
  51. _PR void streamputcntl(VALUE, int);
  52.  
  53. _PR void file_sweep(void);
  54. _PR int    file_cmp(VALUE, VALUE);
  55. _PR void file_prin(VALUE, VALUE);
  56.  
  57. _PR void streams_init(void);
  58. _PR void streams_kill(void);
  59.  
  60. static int
  61. posgetc(TX *tx, POS *pos)
  62. {
  63.     int c = EOF;
  64.     if(pos->pos_Line < tx->tx_NumLines)
  65.     {
  66.     LINE *ln = tx->tx_Lines + pos->pos_Line;
  67.     if(pos->pos_Col >= (ln->ln_Strlen - 1))
  68.     {
  69.         if(++pos->pos_Line == tx->tx_NumLines)
  70.         {
  71.         --pos->pos_Line;
  72.         return(EOF);
  73.         }
  74.         pos->pos_Col = 0;
  75.         return('\n');
  76.     }
  77.     c = ln->ln_Line[pos->pos_Col++];
  78.     }
  79.     return(c);
  80. }
  81. static int
  82. posputc(TX *tx, POS *pos, int c)
  83. {
  84.     int rc = EOF;
  85.     if(!readonly(tx) && padpos(tx, pos))
  86.     {
  87.     u_char tmps[2];
  88.     tmps[0] = (u_char)c;
  89.     tmps[1] = 0;
  90.     if(iscntrl(c))
  91.     {
  92.         if(insertstring(tx, tmps, tx->tx_TabSize, pos))
  93.         rc = 1;
  94.     }
  95.     else
  96.     {
  97.         POS start = *pos;
  98.         if(insertstrn(tx, tmps, 1, pos))
  99.         {
  100.         flaginsertion(tx, &start, pos);
  101.         rc = 1;
  102.         }
  103.     }
  104.     }
  105.     return(rc);
  106. }
  107. static int
  108. posputs(TX *tx, POS *pos, u_char *buf)
  109. {
  110.     int rc = EOF;
  111.     if(!readonly(tx) && padpos(tx, pos))
  112.     {
  113.     if(insertstring(tx, buf, tx->tx_TabSize, pos))
  114.         rc = strlen(buf);
  115.     }
  116.     return(rc);
  117. }
  118.  
  119. int
  120. streamgetc(VALUE stream)
  121. {
  122.     int c = EOF;
  123.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_input)))
  124.     return(c);
  125.     switch(VTYPE(stream))
  126.     {
  127.     VALUE res;
  128.     int oldgci;
  129.     case V_File:
  130.     if(VFILE(stream)->lf_Name)
  131.         c = getc(VFILE(stream)->lf_File);
  132.     break;
  133.     case V_Mark:
  134.     if(!VMARK(stream)->mk_Resident)
  135.         cmd_signal(sym_invalid_stream, list_2(stream, MKSTR("Marks used as streams must be resident")));
  136.     else
  137.         c = posgetc(VMARK(stream)->mk_File.tx, &VPOS(VMARK(stream)->mk_Pos));
  138.     break;
  139.     case V_TX:
  140.     c = posgetc(VTX(stream), gettxcurspos(VTX(stream)));
  141.     break;
  142.     case V_Cons:
  143.     res = VCAR(stream);
  144.     if(NUMBERP(res) && STRINGP(VCDR(stream)))
  145.     {
  146.         c = (int)VSTR(VCDR(stream))[VNUM(res)];
  147.         if(c)
  148.         VCAR(stream) = newnumber(VNUM(res) + 1);
  149.         else
  150.         c = EOF;
  151.         break;
  152.     }
  153.     else if(BUFFERP(res) && POSP(VCDR(stream)))
  154.     {
  155.         c = posgetc(VTX(res), &VPOS(VCDR(stream)));
  156.         break;
  157.     }
  158.     else if(res != sym_lambda)
  159.     {
  160.         cmd_signal(sym_invalid_stream, LIST_1(stream));
  161.         break;
  162.     }
  163.     /* FALL THROUGH */
  164.     case V_Symbol:
  165.     oldgci = GCinhibit;
  166.     GCinhibit = TRUE;
  167.     if((res = calllisp0(stream)) && NUMBERP(res))
  168.         c = VNUM(res);
  169.     GCinhibit = oldgci;
  170.     break;
  171. #ifdef HAVE_UNIX
  172.     case V_Process:
  173.     cmd_signal(sym_invalid_stream, list_2(stream, MKSTR("Processes are not input streams")));
  174.     break;
  175. #endif
  176.     default:
  177.     cmd_signal(sym_invalid_stream, LIST_1(stream));
  178.     }
  179.     return(c);
  180. }
  181.  
  182. /*
  183.  * Puts back one character, it will be read next call to streamgetc on
  184.  * this stream.
  185.  * Note that some types of stream don't actually use c, they just rewind
  186.  * pointers.
  187.  * Never call this unless you *have* *successfully* read from the stream
  188.  * previously. (few checks are performed here, I assume they were made in
  189.  * streamgetc()).
  190.  */
  191. #define POSUNGETC(p,tx) \
  192.     if(--((p)->pos_Col) < 0) \
  193.     { \
  194.     (p)->pos_Line--; \
  195.     (p)->pos_Col = (tx)->tx_Lines[(p)->pos_Line].ln_Strlen - 1; \
  196.     }
  197. int
  198. streamungetc(VALUE stream, int c)
  199. {
  200.     int rc = FALSE;
  201.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_input)))
  202.     return(rc);
  203.     switch(VTYPE(stream))
  204.     {
  205.     POS *pos;
  206.     VALUE tmp;
  207.     int oldgci;
  208.     case V_File:
  209.     if(ungetc(c, VFILE(stream)->lf_File) != EOF)
  210.         rc = TRUE;
  211.     break;
  212.     case V_Mark:
  213.     pos = &VPOS(VMARK(stream)->mk_Pos);
  214.     POSUNGETC(pos, VMARK(stream)->mk_File.tx)
  215.     rc = TRUE;
  216.     break;
  217.     case V_TX:
  218.     pos = gettxcurspos(VTX(stream));
  219.     POSUNGETC(pos, VTX(stream))
  220.     rc = TRUE;
  221.     break;
  222.     case V_Cons:
  223.     tmp = VCAR(stream);
  224.     if(NUMBERP(tmp) && STRINGP(VCDR(stream)))
  225.     {
  226.         VCAR(stream) = newnumber(VNUM(tmp) - 1);
  227.         rc = TRUE;
  228.         break;
  229.     }
  230.     else if(BUFFERP(tmp) && POSP(VCDR(stream)))
  231.     {
  232.         POSUNGETC(&VPOS(VCDR(stream)), VTX(tmp));
  233.         rc = TRUE;
  234.         break;
  235.     }
  236.     /* FALL THROUGH */
  237.     case V_Symbol:
  238.     tmp = newnumber(c);
  239.     oldgci = GCinhibit;
  240.     GCinhibit = TRUE;
  241.     if((tmp = calllisp1(stream, tmp)) && !NILP(tmp))
  242.         rc = TRUE;
  243.     GCinhibit = oldgci;
  244.     break;
  245.     }
  246.     return(rc);
  247. }
  248.  
  249. int
  250. streamputc(VALUE stream, int c)
  251. {
  252.     int rc = 0;
  253.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_output)))
  254.     return(rc);
  255.     switch(VTYPE(stream))
  256.     {
  257.     VALUE args, res, new;
  258.     int len;
  259.     u_char tmps[2];
  260.     POS pos;
  261.     int oldgci;
  262.     case V_File:
  263.     if(VFILE(stream)->lf_Name)
  264.     {
  265.         if(putc(c, VFILE(stream)->lf_File) != EOF)
  266.         rc = 1;
  267.     }
  268.     break;
  269.     case V_Mark:
  270.     if(!VMARK(stream)->mk_Resident)
  271.         cmd_signal(sym_invalid_stream, list_2(stream, MKSTR("Marks used as streams must be resident")));
  272.     else
  273.     {
  274.         pos = VPOS(VMARK(stream)->mk_Pos);
  275.         rc = posputc(VMARK(stream)->mk_File.tx, &pos, c);
  276.     }
  277.     break;
  278.     case V_TX:
  279.     pos = *(gettxcurspos(VTX(stream)));
  280.     rc = posputc(VTX(stream), &pos, c);
  281.     break;
  282.     case V_Cons:
  283.     args = VCAR(stream);
  284.     if(STRINGP(args))
  285.     {
  286.         len = strlen(VSTR(args));
  287.         new = valstralloc(len + 2);
  288.         if(new)
  289.         {
  290.         memcpy(VSTR(new), VSTR(args), len);
  291.         VSTR(new)[len] = (u_char)c;
  292.         VSTR(new)[len+1] = 0;
  293.         VCAR(stream) = new;
  294.         rc = 1;
  295.         }
  296.         break;
  297.     }
  298.     else if(BUFFERP(args))
  299.     {
  300.         if(POSP(VCDR(stream)))
  301.         rc = posputc(VTX(args), &VPOS(VCDR(stream)), c);
  302.         else
  303.         {
  304.         pos.pos_Line = VTX(args)->tx_NumLines - 1;
  305.         pos.pos_Col = VTX(args)->tx_Lines[pos.pos_Line].ln_Strlen - 1;
  306.         rc = posputc(VTX(args), &pos, c);
  307.         }
  308.         break;
  309.     }
  310.     else if(args != sym_lambda)
  311.     {
  312.         cmd_signal(sym_invalid_stream, LIST_1(stream));
  313.         break;
  314.     }
  315.     /* FALL THROUGH */
  316.     case V_Symbol:
  317.     if(stream == sym_t)
  318.     {
  319.         if(CurrVW->vw_NonStdTitle)
  320.         {
  321.         VW *vw = CurrVW;
  322.         u_char *s;
  323.         len = strlen(vw->vw_LastTitle);
  324.         s = mystrdupn(vw->vw_LastTitle, len + 1);
  325.         if(s)
  326.         {
  327.             s[len] = c;
  328.             s[len + 1] = 0;
  329.             mystrfree(vw->vw_LastTitle);
  330.             vw->vw_LastTitle = s;
  331.             vw->vw_Flags |= VWFF_REFRESH_STATUS;
  332.         }
  333.         }
  334.         else
  335.         {
  336.         tmps[0] = (u_char)c;
  337.         tmps[1] = 0;
  338.         settitle(tmps);
  339.         }
  340.         rc = 1;
  341.     }
  342.     else
  343.     {
  344.         oldgci = GCinhibit;
  345.         GCinhibit = TRUE;
  346.         if((res = calllisp1(stream, newnumber(c))) && !NILP(res))
  347.         rc = 1;
  348.         GCinhibit = oldgci;
  349.     }
  350.     break;
  351. #ifdef HAVE_UNIX
  352.     case V_Process:
  353.     tmps[0] = (u_char)c;
  354.     tmps[1] = 0;
  355.     rc = writetoproc(stream, tmps);
  356.     break;
  357. #endif
  358.     default:
  359.     cmd_signal(sym_invalid_stream, LIST_1(stream));
  360.     }
  361.     return(rc);
  362. }
  363.  
  364. int
  365. streamputs(VALUE stream, u_char *buf, int isValString)
  366. {
  367.     int rc = 0;
  368.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_output)))
  369.     return(rc);
  370.     switch(VTYPE(stream))
  371.     {
  372.     VALUE args, res, new;
  373.     int len, newlen;
  374.     POS pos;
  375.     int oldgci;
  376.     case V_File:
  377.     if(VFILE(stream)->lf_Name)
  378.     {
  379.         if((rc = fputs(buf, VFILE(stream)->lf_File)) != EOF)
  380.         rc = strlen(buf);
  381.     }
  382.     break;
  383.     case V_Mark:
  384.     if(!VMARK(stream)->mk_Resident)
  385.         cmd_signal(sym_invalid_stream, list_2(stream, MKSTR("Marks used as streams must be resident")));
  386.     else
  387.     {
  388.         pos = VPOS(VMARK(stream)->mk_Pos);
  389.         rc = posputs(VMARK(stream)->mk_File.tx, &pos, buf);
  390.     }
  391.     break;
  392.     case V_TX:
  393.     pos = *(gettxcurspos(VTX(stream)));
  394.     rc = posputs(VTX(stream), &pos, buf);
  395.     break;
  396.     case V_Cons:
  397.     args = VCAR(stream);
  398.     if(STRINGP(args))
  399.     {
  400.         len = strlen(VSTR(args));
  401.         newlen = len + strlen(buf);
  402.         new = valstralloc(newlen + 1);
  403.         if(new)
  404.         {
  405.         memcpy(VSTR(new), VSTR(args), len);
  406.         strcpy(VSTR(new) + len, buf);
  407.         VCAR(stream) = new;
  408.         rc = newlen - len;
  409.         }
  410.         break;
  411.     }
  412.     else if(BUFFERP(args))
  413.     {
  414.         if(POSP(VCDR(stream)))
  415.         rc = posputs(VTX(args), &VPOS(VCDR(stream)), buf);
  416.         else
  417.         {
  418.         pos.pos_Line = VTX(args)->tx_NumLines - 1;
  419.         pos.pos_Col = VTX(args)->tx_Lines[pos.pos_Line].ln_Strlen - 1;
  420.         rc = posputs(VTX(args), &pos, buf);
  421.         }
  422.         break;
  423.     }
  424.     else if(args != sym_lambda)
  425.     {
  426.         cmd_signal(sym_invalid_stream, LIST_1(stream));
  427.         break;
  428.     }
  429.     /* FALL THROUGH */
  430.     case V_Symbol:
  431.     if(stream == sym_t)
  432.     {
  433.         len = strlen(buf);
  434.         if(CurrVW->vw_NonStdTitle)
  435.         {
  436.         VW *vw = CurrVW;
  437.         u_char *s;
  438.         newlen = strlen(vw->vw_LastTitle) + len;
  439.         s = mystrdupn(vw->vw_LastTitle, newlen);
  440.         if(s)
  441.         {
  442.             strcpy(s + (newlen - len), buf);
  443.             mystrfree(vw->vw_LastTitle);
  444.             vw->vw_LastTitle = s;
  445.             vw->vw_Flags |= VWFF_REFRESH_STATUS;
  446.         }
  447.         }
  448.         else
  449.         settitle(buf);
  450.         rc = len;
  451.     }
  452.     else
  453.     {
  454.         if(isValString)
  455.         args = buf - 1;
  456.         else
  457.         args = valstrdup(buf);
  458.         oldgci = GCinhibit;
  459.         GCinhibit = TRUE;
  460.         if((res = calllisp1(stream, args)) && !NILP(res))
  461.         {
  462.         if(NUMBERP(res))
  463.             rc = VNUM(res);
  464.         else
  465.             rc = strlen(buf);
  466.         }
  467.         GCinhibit = oldgci;
  468.     }
  469.     break;
  470. #ifdef HAVE_UNIX
  471.     case V_Process:
  472.     rc = writetoproc(stream, buf);
  473.     break;
  474. #endif
  475.     default:
  476.     cmd_signal(sym_invalid_stream, LIST_1(stream));
  477.     }
  478.     return(rc);
  479. }
  480.  
  481. u_char
  482. escstreamchar(VALUE stream, int *c_p)
  483. {
  484.     u_char c;
  485.     switch(*c_p)
  486.     {
  487.     case 'n':
  488.     c = '\n';
  489.     break;
  490.     case 'r':
  491.     c = '\r';
  492.     break;
  493.     case 'f':
  494.     c = '\f';
  495.     break;
  496.     case 't':
  497.     c = '\t';
  498.     break;
  499.     case 'a':
  500.     c = '\a';
  501.     break;
  502.     case '^':
  503.     c = toupper(streamgetc(stream)) ^ 0x40;
  504.     break;
  505.     case '0':
  506.     case '1':
  507.     case '2':
  508.     case '3':
  509.     c = (*c_p - '0') * 64;
  510.     c += ((streamgetc(stream) - '0') * 8);
  511.     c += (streamgetc(stream) - '0');
  512.     break;
  513.     default:
  514.     c = *c_p;
  515.     }
  516.     *c_p = streamgetc(stream);
  517.     return(c);
  518. }
  519. void
  520. streamputcntl(VALUE stream, int c)
  521. {
  522.     u_char buff[40];
  523.     u_char *buf = buff + 1;
  524.     buff[0] = V_String;
  525.     switch(c)
  526.     {
  527.     case '\n':
  528.     strcpy(buf, "\\n");
  529.     break;
  530.     case '\t':
  531.     strcpy(buf, "\\t");
  532.     break;
  533.     case '\r':
  534.     strcpy(buf, "\\r");
  535.     break;
  536.     case '\f':
  537.     strcpy(buf, "\\f");
  538.     break;
  539.     case '\a':
  540.     strcpy(buf, "\\a");
  541.     break;
  542.     default:
  543.     if(c <= 0x3f)
  544.         sprintf(buf, "\\^%c", c + 0x40);
  545.     else
  546.         sprintf(buf, "\\%03o", (int)c);
  547.     break;
  548.     }
  549.     streamputs(stream, buf, TRUE);
  550. }
  551.  
  552. _PR VALUE cmd_write(VALUE stream, VALUE data);
  553. DEFUN("write", cmd_write, subr_write, (VALUE stream, VALUE data), V_Subr2, DOC_write) /*
  554. ::doc:write::
  555. (write STREAM DATA)
  556. Writes DATA, which can either be a string or a character, to the stream
  557. STREAM, returning the number of characters actually written.
  558. ::end:: */
  559. {
  560.     int actual;
  561.     switch(VTYPE(data))
  562.     {
  563.     case V_Number:
  564.     actual = streamputc(stream, VNUM(data));
  565.     break;
  566.     case V_StaticString:
  567.     case V_String:
  568.     actual = streamputs(stream, VSTR(data), TRUE);
  569.     break;
  570.     default:
  571.     cmd_signal(sym_bad_arg, list_2(data, newnumber(2)));
  572.     return(NULL);
  573.     }
  574.     return(newnumber(actual));
  575. }
  576.  
  577. _PR VALUE cmd_read_char(VALUE stream);
  578. DEFUN("read-char", cmd_read_char, subr_read_char, (VALUE stream), V_Subr1, DOC_read_char) /*
  579. ::doc:read_char::
  580. (read-char STREAM)
  581. Reads the next character from the input-stream STREAM, if no more characters
  582. are available returns nil.
  583. ::end:: */
  584. {
  585.     int rc;
  586.     if((rc = streamgetc(stream)) != EOF)
  587.     return(newnumber(rc));
  588.     return(sym_nil);
  589. }
  590.  
  591. _PR VALUE cmd_read_line(VALUE stream);
  592. DEFUN("read-line", cmd_read_line, subr_read_line, (VALUE stream), V_Subr1, DOC_read_line) /*
  593. ::doc:read_line::
  594. (read-line STREAM)
  595. Read one line of text from STREAM.
  596. ::end:: */
  597. {
  598.     u_char buf[400];
  599.     if(FILEP(stream))
  600.     {
  601.     /* Special case for file streams. We can read a line in one go.     */
  602.     if(VFILE(stream)->lf_Name && fgets(buf, 400, VFILE(stream)->lf_File))
  603.         return(valstrdup(buf));
  604.     return(sym_nil);
  605.     }
  606.     else
  607.     {
  608.     u_char *bufp = buf;
  609.     int len = 0, c;
  610.     while((c = streamgetc(stream)) != EOF)
  611.     {
  612.         *bufp++ = (u_char)c;
  613.         if((++len >= 399) || (c == '\n'))
  614.         break;
  615.     }
  616.     if(len == 0)
  617.         return(sym_nil);
  618.     return(valstrdupn(buf, len));
  619.     }
  620. }
  621.  
  622. _PR VALUE cmd_copy_stream(VALUE source, VALUE dest);
  623. DEFUN("copy-stream", cmd_copy_stream, subr_copy_stream, (VALUE source, VALUE dest), V_Subr2, DOC_copy_stream) /*
  624. ::doc:copy_stream::
  625. (copy-stream SOURCE-STREAM DEST-STREAM)
  626. Copy all characters from SOURCE-STREAM to DEST-STREAM until an EOF is read.
  627. ::end:: */
  628. {
  629.     int len = 0, i = 0, c;
  630.     u_char buff[402];
  631.     u_char *buf = buff + 1;
  632.     buff[0] = V_StaticString;
  633.     while((c = streamgetc(source)) != EOF)
  634.     {
  635.     if(i == 400)
  636.     {
  637.         buf[i] = 0;
  638.         if(streamputs(dest, buf, TRUE) == EOF)
  639.         break;
  640.         i = 0;
  641.     }
  642.     else
  643.         buf[i++] = c;
  644.     len++;
  645.     }
  646.     if(i > 0)
  647.     {
  648.     buff[i] = 0;
  649.     streamputs(dest, buf, TRUE);
  650.     }
  651.     if(len)
  652.     return(newnumber(len));
  653.     return(sym_nil);
  654. }
  655.  
  656. _PR VALUE cmd_read(VALUE);
  657. DEFUN("read", cmd_read, subr_read, (VALUE stream), V_Subr1, DOC_read) /*
  658. ::doc:read::
  659. (read [STREAM])
  660. Reads one lisp-object from the input-stream STREAM (or the value of the
  661. variable `standard-input' if STREAM is unspecified) and return it.
  662. ::end:: */
  663. {
  664.     VALUE res;
  665.     int c;
  666.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_input)))
  667.     {
  668.     signalargerror(stream, 1);
  669.     return(NULL);
  670.     }
  671.     c = streamgetc(stream);
  672.     if(c == EOF)
  673.     res = cmd_signal(sym_end_of_stream, LIST_1(stream));
  674.     else
  675.     res = readlispexp(stream, &c);
  676.     /* If an error occurred leave stream where it is.  */
  677.     if(res && c != EOF)
  678.     streamungetc(stream, c);
  679.     return(res);
  680. }
  681.  
  682. _PR VALUE cmd_print(VALUE, VALUE);
  683. DEFUN("print", cmd_print, subr_print, (VALUE obj, VALUE stream), V_Subr2, DOC_print) /*
  684. ::doc:print::
  685. (print OBJECT [STREAM])
  686. First outputs a newline, then prints a text representation of OBJECT to
  687. STREAM (or the contents of the variable `standard-output') in a form suitable
  688. for `read'.
  689. ::end:: */
  690. {
  691.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_output)))
  692.     {
  693.     signalargerror(stream, 1);
  694.     return(NULL);
  695.     }
  696.     streamputc(stream, '\n');
  697.     printval(stream, obj);
  698.     return(stream);
  699. }
  700.  
  701. _PR VALUE cmd_prin1(VALUE, VALUE);
  702. DEFUN("prin1", cmd_prin1, subr_prin1, (VALUE obj, VALUE stream), V_Subr2, DOC_prin1) /*
  703. ::doc:prin1::
  704. (prin1 OBJECT [STREAM])
  705. Prints a text representation of OBJECT to STREAM (or the contents of the
  706. variable `standard-output') in a form suitable for `read'.
  707. ::end:: */
  708. {
  709.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_output)))
  710.     {
  711.     signalargerror(stream, 1);
  712.     return(NULL);
  713.     }
  714.     printval(stream, obj);
  715.     return(stream);
  716. }
  717.  
  718. _PR VALUE cmd_princ(VALUE, VALUE);
  719. DEFUN("princ", cmd_princ, subr_princ, (VALUE obj, VALUE stream), V_Subr2, DOC_princ) /*
  720. ::doc:princ::
  721. (princ OBJECT [STREAM])
  722. Prints a text representation of OBJECT to STREAM (or the contents of the
  723. variable standard-output), no strange characters are quoted and no quotes
  724. are printed around strings.
  725. ::end:: */
  726. {
  727.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_output)))
  728.     {
  729.     signalargerror(stream, 1);
  730.     return(NULL);
  731.     }
  732.     princval(stream, obj);
  733.     return(stream);
  734. }
  735.  
  736. _PR VALUE cmd_format(VALUE);
  737. DEFUN("format", cmd_format, subr_format, (VALUE args), V_SubrN, DOC_format) /*
  738. ::doc:format::
  739. (format STREAM FORMAT-STRING ARGS... )
  740. Writes a string created from the format specification FORMAT-STRING and
  741. the argument-values ARGS to the stream, STREAM.
  742. FORMAT-STRING is a template for the result, any `%' characters introduce
  743. a substitution, using the next unused ARG. These format specifiers are
  744. implemented:
  745.    d      print next ARG as decimal integer
  746.    x      print next ARG as hexadecimal integer
  747.    c      print next ARG as ASCII character
  748.    s      unquoted representation (as from `princ') of next ARG
  749.    S      normal print'ed representation of next ARG
  750.    %      literal percentage character
  751.  
  752. Returns STREAM.
  753. ::end:: */
  754. {
  755.     u_char *fmt;
  756.     VALUE stream = ARG2;
  757.     u_char c;
  758.     DECLARE1(stream, STRINGP);
  759.     fmt = VSTR(stream);
  760.     stream = ARG1;
  761.     if(NILP(stream) && !(stream = cmd_symbol_value(sym_standard_output)))
  762.     {
  763.     signalargerror(stream, 1);
  764.     return(NULL);
  765.     }
  766.     args = movedownlist(args, 2);
  767.     while((c = *fmt++))
  768.     {
  769.     if(c == '%')
  770.     {
  771.         u_char tbuf[40], nfmt[4];
  772.         VALUE val = ARG1;
  773.         switch(c = *fmt++)
  774.         {
  775.         case 'd':
  776.         case 'x':
  777.         case 'c':
  778.         nfmt[0] = '%';
  779.         nfmt[1] = 'l';
  780.         nfmt[2] = c;
  781.         nfmt[3] = 0;
  782.         sprintf(tbuf, nfmt, NUMBERP(val) ? VNUM(val) : (long)val);
  783.         streamputs(stream, tbuf, FALSE);
  784.         break;
  785.         case 's':
  786.         princval(stream, val);
  787.         break;
  788.         case 'S':
  789.         printval(stream, val);
  790.         break;
  791.         case '%':
  792.         streamputc(stream, '%');
  793.         break;
  794.         }
  795.         args = movedownlist(args, 1);
  796.     }
  797.     else
  798.         streamputc(stream, c);
  799.     }
  800.     return(stream);
  801. }
  802.  
  803. LFile *LFileChain;
  804.  
  805. void
  806. file_sweep(void)
  807. {
  808.     LFile *lf = LFileChain;
  809.     LFileChain = NULL;
  810.     while(lf)
  811.     {
  812.     LFile *nxt = lf->lf_Next;
  813.     if(!GC_MARKEDP(lf))
  814.     {
  815.         if(lf->lf_Name && !(lf->lf_Flags & LFF_DONT_CLOSE))
  816.         fclose(lf->lf_File);
  817.         mystrfree(lf);
  818.     }
  819.     else
  820.     {
  821.         GC_CLR(lf);
  822.         lf->lf_Next = LFileChain;
  823.         LFileChain = lf;
  824.     }
  825.     lf = nxt;
  826.     }
  827. }
  828. int
  829. file_cmp(VALUE v1, VALUE v2)
  830. {
  831.     if(VTYPE(v1) == VTYPE(v2))
  832.     {
  833.     if(VFILE(v1)->lf_Name && VFILE(v2)->lf_Name)
  834.         return(!samefiles(VSTR(VFILE(v1)->lf_Name), VSTR(VFILE(v2)->lf_Name)));
  835.     }
  836.     return(1);
  837. }
  838. void
  839. file_prin(VALUE strm, VALUE obj)
  840. {
  841.     streamputs(strm, "#<file ", FALSE);
  842.     if(VFILE(obj)->lf_Name)
  843.     {
  844.     streamputs(strm, VSTR(VFILE(obj)->lf_Name), FALSE);
  845.     streamputc(strm, '>');
  846.     }
  847.     else
  848.     streamputs(strm, "*unbound*>", FALSE);
  849. }
  850.  
  851. _PR VALUE cmd_open(VALUE name, VALUE modes, VALUE file);
  852. DEFUN("open", cmd_open, subr_open, (VALUE name, VALUE modes, VALUE file), V_Subr3, DOC_open) /*
  853. ::doc:open::
  854. (open [FILE-NAME MODE-STRING] [FILE])
  855. Opens a file called FILE-NAME with modes MODE-STRING (standard c-library
  856. modes, ie `r' == read, `w' == write, etc). If FILE is given it is an
  857. existing file object which is to be closed before opening the new file on it.
  858. ::end:: */
  859. {
  860.     LFile *lf;
  861.     if(!FILEP(file))
  862.     {
  863.     lf = mystralloc(sizeof(LFile));
  864.     if(lf)
  865.     {
  866.         lf->lf_Next = LFileChain;
  867.         LFileChain = lf;
  868.         lf->lf_Type = V_File;
  869.     }
  870.     }
  871.     else
  872.     {
  873.     lf = VFILE(file);
  874.     if(lf->lf_Name && !(lf->lf_Flags & LFF_DONT_CLOSE))
  875.         fclose(lf->lf_File);
  876.     }
  877.     if(lf)
  878.     {
  879.     lf->lf_File = lf->lf_Name = NULL;
  880.     lf->lf_Flags = 0;
  881.     if(STRINGP(name) && STRINGP(modes))
  882.     {
  883.         lf->lf_File = fopen(VSTR(name), VSTR(modes));
  884.         if(lf->lf_File)
  885.         {
  886.         lf->lf_Name = name;
  887. #ifdef HAVE_UNIX
  888.         /*
  889.          * set close-on-exec for easy process fork()ing
  890.          */
  891.         fcntl(fileno(lf->lf_File), F_SETFD, 1);
  892. #endif
  893.         }
  894.         else
  895.         return(cmd_signal(sym_file_error, list_2(geterrstring(), name)));
  896.     }
  897.     return(lf);
  898.     }
  899.     return(NULL);
  900. }
  901.  
  902. _PR VALUE cmd_close(VALUE file);
  903. DEFUN("close", cmd_close, subr_close, (VALUE file), V_Subr1, DOC_close) /*
  904. ::doc:close::
  905. (close FILE)
  906. Kills any association between object FILE and the file in the filesystem that
  907. it has open.
  908. ::end:: */
  909. {
  910.     DECLARE1(file, FILEP);
  911.     if(VFILE(file)->lf_Name && !(VFILE(file)->lf_Flags & LFF_DONT_CLOSE))
  912.     fclose(VFILE(file)->lf_File);
  913.     VFILE(file)->lf_File = VFILE(file)->lf_Name = NULL;
  914.     return(file);
  915. }
  916.  
  917. _PR VALUE cmd_flush_file(VALUE file);
  918. DEFUN("flush-file", cmd_flush_file, subr_flush_file, (VALUE file), V_Subr1, DOC_flush_file) /*
  919. ::doc:flush_file::
  920. (flush-file FILE)
  921. Flushes any buffered output on FILE.
  922. ::end:: */
  923. {
  924.     DECLARE1(file, FILEP);
  925.     if(VFILE(file)->lf_Name)
  926.     fflush(VFILE(file)->lf_File);
  927.     return(file);
  928. }
  929.  
  930. _PR VALUE cmd_file_p(VALUE arg);
  931. DEFUN("file-p", cmd_file_p, subr_file_p, (VALUE arg), V_Subr1, DOC_file_p) /*
  932. ::doc:file_p::
  933. (file-p ARG)
  934. Returns t if ARG is a file object.
  935. ::end:: */
  936. {
  937.     if(FILEP(arg))
  938.     return(sym_t);
  939.     return(sym_nil);
  940. }
  941.  
  942. _PR VALUE cmd_file_bound_p(VALUE file);
  943. DEFUN("file-bound-p", cmd_file_bound_p, subr_file_bound_p, (VALUE file), V_Subr1, DOC_file_bound_p) /*
  944. ::doc:file_bound_p::
  945. (file-bound-p FILE)
  946. Returns t if FILE is currently bound to a physical file.
  947. ::end:: */
  948. {
  949.     DECLARE1(file, FILEP);
  950.     if(VFILE(file)->lf_Name)
  951.     return(sym_t);
  952.     return(sym_nil);
  953. }
  954.  
  955. _PR VALUE cmd_file_binding(VALUE file);
  956. DEFUN("file-binding", cmd_file_binding, subr_file_binding, (VALUE file), V_Subr1, DOC_file_binding) /*
  957. ::doc:file_binding::
  958. (file-binding FILE)
  959. Returns the name of the physical file FILE is bound to, or nil.
  960. ::end:: */
  961. {
  962.     DECLARE1(file, FILEP);
  963.     if(VFILE(file)->lf_Name)
  964.     return(VFILE(file)->lf_Name);
  965.     return(sym_nil);
  966. }
  967.  
  968. _PR VALUE cmd_file_eof_p(VALUE file);
  969. DEFUN("file-eof-p", cmd_file_eof_p, subr_file_eof_p, (VALUE file), V_Subr1, DOC_file_eof_p) /*
  970. ::doc:file_eof_p::
  971. (file-eof-p FILE
  972. Returns t when end of FILE is reached.
  973. ::end:: */
  974. {
  975.     DECLARE1(file, FILEP);
  976.     if(VFILE(file)->lf_Name && feof(VFILE(file)->lf_File))
  977.     return(sym_t);
  978.     return(sym_nil);
  979. }
  980.  
  981. _PR VALUE cmd_read_file_until(VALUE file, VALUE re, VALUE nocase_p);
  982. DEFUN("read-file-until", cmd_read_file_until, subr_read_file_until, (VALUE file, VALUE re, VALUE nocase_p), V_Subr3, DOC_read_file_until) /*
  983. ::doc:read_file_until::
  984. (read-file-until FILE REGEXP [IGNORE-CASE-P])
  985. Read lines from the Lisp file object FILE until one matching the regular
  986. expression REGEXP is found. The matching line is returned, or nil if no
  987. lines match.
  988. If IGNORE-CASE-P is non-nil the regexp matching is not case-sensitive.
  989. ::end:: */
  990. {
  991.     regexp *prog;
  992.     u_char buf[400];        /* Fix this later. */
  993.     DECLARE1(file, FILEP);
  994.     DECLARE2(re, STRINGP);
  995.     if(!VFILE(file)->lf_Name)
  996.     return(cmd_signal(sym_bad_arg, list_2(MKSTR("File object is unbound"), file)));
  997.     prog = regcomp(VSTR(re));
  998.     if(prog)
  999.     {
  1000.     int eflags = NILP(nocase_p) ? 0 : REG_NOCASE;
  1001.     FILE *fh = VFILE(file)->lf_File;
  1002.     VALUE res = sym_nil;
  1003.     while(fgets(buf, 400, fh))
  1004.     {
  1005.         if(regexec2(prog, buf, eflags))
  1006.         {
  1007.         res = valstrdup(buf);
  1008.         break;
  1009.         }
  1010.     }
  1011.     free(prog);
  1012.     return(res);
  1013.     }
  1014.     return(NULL);
  1015. }
  1016.  
  1017. _PR VALUE cmd_stdin_file(void);
  1018. DEFUN("stdin-file", cmd_stdin_file, subr_stdin_file, (void), V_Subr0, DOC_stdin_file) /*
  1019. ::doc:stdin_file::
  1020. (stdin-file)
  1021. Returns the file object representing the editor's standard input.
  1022. ::end:: */
  1023. {
  1024.     static VALUE stdin_file;
  1025.     if(stdin_file)
  1026.     return(stdin_file);
  1027.     stdin_file = cmd_open(sym_nil, sym_nil, sym_nil);
  1028.     VFILE(stdin_file)->lf_Name = MKSTR("<stdin>");
  1029.     VFILE(stdin_file)->lf_File = stdin;
  1030.     VFILE(stdin_file)->lf_Flags |= LFF_DONT_CLOSE;
  1031.     markstatic(&stdin_file);
  1032.     return(stdin_file);
  1033. }
  1034.  
  1035. _PR VALUE cmd_stdout_file(void);
  1036. DEFUN("stdout-file", cmd_stdout_file, subr_stdout_file, (void), V_Subr0, DOC_stdout_file) /*
  1037. ::doc:stdout_file::
  1038. (stdout-file)
  1039. Returns the file object representing the editor's standard output.
  1040. ::end:: */
  1041. {
  1042.     static VALUE stdout_file;
  1043.     if(stdout_file)
  1044.     return(stdout_file);
  1045.     stdout_file = cmd_open(sym_nil, sym_nil, sym_nil);
  1046.     VFILE(stdout_file)->lf_Name = MKSTR("<stdout>");
  1047.     VFILE(stdout_file)->lf_File = stdout;
  1048.     VFILE(stdout_file)->lf_Flags |= LFF_DONT_CLOSE;
  1049.     markstatic(&stdout_file);
  1050.     return(stdout_file);
  1051. }
  1052.  
  1053. void
  1054. streams_init(void)
  1055. {
  1056.     ADD_SUBR(subr_write);
  1057.     ADD_SUBR(subr_read_char);
  1058.     ADD_SUBR(subr_read_line);
  1059.     ADD_SUBR(subr_copy_stream);
  1060.     ADD_SUBR(subr_read);
  1061.     ADD_SUBR(subr_print);
  1062.     ADD_SUBR(subr_prin1);
  1063.     ADD_SUBR(subr_princ);
  1064.     ADD_SUBR(subr_format);
  1065.     ADD_SUBR(subr_open);
  1066.     ADD_SUBR(subr_close);
  1067.     ADD_SUBR(subr_flush_file);
  1068.     ADD_SUBR(subr_file_p);
  1069.     ADD_SUBR(subr_file_bound_p);
  1070.     ADD_SUBR(subr_file_binding);
  1071.     ADD_SUBR(subr_file_eof_p);
  1072.     ADD_SUBR(subr_read_file_until);
  1073.     ADD_SUBR(subr_stdin_file);
  1074.     ADD_SUBR(subr_stdout_file);
  1075. }
  1076. void
  1077. streams_kill(void)
  1078. {
  1079.     LFile *lf = LFileChain;
  1080.     while(lf)
  1081.     {
  1082.     LFile *nxt = lf->lf_Next;
  1083.     if(lf->lf_Name && !(lf->lf_Flags & LFF_DONT_CLOSE))
  1084.         fclose(lf->lf_File);
  1085.     mystrfree(lf);
  1086.     lf = nxt;
  1087.     }
  1088. }
  1089.