libguile/rdelim.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41
  42  * This is the C part of the module for delimited I/O.  It's
  43  * similar to (scsh rdelim) but somewhat incompatible.  */
  44
  45 #include "libguile/_scm.h"
  46
  47 #include <stdio.h>
  48
  49 #ifdef HAVE_STRING_H
  50 #include <string.h>
  51 #endif
  52
  53 #include "libguile/chars.h"
  54 #include "libguile/modules.h"
  55 #include "libguile/ports.h"
  56 #include "libguile/rdelim.h"
  57 #include "libguile/root.h"
  58 #include "libguile/strings.h"
  59 #include "libguile/strports.h"
  60 #include "libguile/validate.h"
  61
  62 SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
  63             (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end),
  64             "Read characters from @var{port} into @var{str} until one of the\n"
  65             "characters in the @var{delims} string is encountered.  If @var{gobble}\n"
  66             "is true, discard the delimiter character; otherwise, leave it\n"
  67             "in the input stream for the next read.\n"
  68             "If @var{port} is not specified, use the value of\n"
  69             "@code{(current-input-port)}.  If @var{start} or @var{end} are specified,\n"
  70             "store data only into the substring of @var{str} bounded by @var{start}\n"
  71             "and @var{end} (which default to the beginning and end of the string,\n"
  72             "respectively).\n\n"
  73             "Return a pair consisting of the delimiter that terminated the string and\n"
  74             "the number of characters read.  If reading stopped at the end of file,\n"
  75             "the delimiter returned is the @var{eof-object}; if the string was filled\n"
  76             "without encountering a delimiter, this value is @var{#f}.")
  77 #define FUNC_NAME s_scm_read_delimited_x
  78 {
  79   long j;
  80   char *buf;
  81   long cstart;
  82   long cend;
  83   int c;
  84   char *cdelims;
  85   int num_delims;
  86
  87   SCM_VALIDATE_STRING_COPY (1, delims, cdelims);
  88   num_delims = SCM_STRING_LENGTH (delims);
  89   SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, str, buf, 5, start, cstart,
  90                                     6, end, cend);
  91   if (SCM_UNBNDP (port))
  92     port = scm_cur_inp;
  93   else
  94     SCM_VALIDATE_OPINPORT (4,port);
  95
  96   for (j = cstart; j < cend; j++)
  97     {
  98       int k;
  99
 100       c = scm_getc (port);
 101       for (k = 0; k < num_delims; k++)
 102         {
 103           if (cdelims[k] == c)
 104             {
 105               if (SCM_FALSEP (gobble))
 106                 scm_ungetc (c, port);
 107
 108               return scm_cons (SCM_MAKE_CHAR (c),
 109                                scm_long2num (j - cstart));
 110             }
 111         }
 112       if (c == EOF)
 113         return scm_cons (SCM_EOF_VAL,
 114                          scm_long2num (j - cstart));
 115
 116       buf[j] = c;
 117     }
 118   return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
 119 }
 120 #undef FUNC_NAME
 121
 122 static unsigned char *
 123 scm_do_read_line (SCM port, int *len_p)
 124 {
 125   scm_port *pt = SCM_PTAB_ENTRY (port);
 126   unsigned char *end;
 127
 128   /* I thought reading lines was simple.  Mercy me.  */
 129
 130   /* The common case: the buffer contains a complete line.
 131      This needs to be fast.  */
 132   if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
 133            != 0)
 134     {
 135       int buf_len = (end + 1) - pt->read_pos;
 136       /* Allocate a buffer of the perfect size.  */
 137       unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line");
 138
 139       memcpy (buf, pt->read_pos, buf_len);
 140       pt->read_pos += buf_len;
 141
 142       buf[buf_len] = '\0';
 143
 144       *len_p = buf_len;
 145       return buf;
 146     }
 147
 148   /* The buffer contains no newlines.  */
 149   {
 150     /* When live, len is always the number of characters in the
 151        current buffer that are part of the current line.  */
 152     int len = (pt->read_end - pt->read_pos);
 153     int buf_size = (len < 50) ? 60 : len * 2;
 154     /* Invariant: buf always has buf_size + 1 characters allocated;
 155        the `+ 1' is for the final '\0'.  */
 156     unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line");
 157     int buf_len = 0;
 158
 159     for (;;)
 160       {
 161         if (buf_len + len > buf_size)
 162           {
 163             int new_size = (buf_len + len) * 2;
 164             buf = scm_must_realloc (buf, buf_size + 1, new_size + 1,
 165                                     "%read-line");
 166             buf_size = new_size;
 167           }
 168
 169         /* Copy what we've got out of the port, into our buffer.  */
 170         memcpy (buf + buf_len, pt->read_pos, len);
 171         buf_len += len;
 172         pt->read_pos += len;
 173
 174         /* If we had seen a newline, we're done now.  */
 175         if (end)
 176           break;
 177
 178         /* Get more characters.  */
 179         if (scm_fill_input (port) == EOF)
 180           {
 181             /* If we're missing a final newline in the file, return
 182                what we did get, sans newline.  */
 183             if (buf_len > 0)
 184               break;
 185
 186             free (buf);
 187             return 0;
 188           }
 189
 190         /* Search the buffer for newlines.  */
 191         if ((end = memchr (pt->read_pos, '\n',
 192                            (len = (pt->read_end - pt->read_pos))))
 193             != 0)
 194           len = (end - pt->read_pos) + 1;
 195       }
 196
 197     /* I wonder how expensive this realloc is.  */
 198     buf = scm_must_realloc (buf, buf_size + 1, buf_len + 1, "%read-line");
 199     buf[buf_len] = '\0';
 200     *len_p = buf_len;
 201     return buf;
 202   }
 203 }
 204
 205
 206 /*
 207  * %read-line
 208  * truncates any terminating newline from its input, and returns
 209  * a cons of the string read and its terminating character.  Doing
 210  * so makes it easy to implement the hairy `read-line' options
 211  * efficiently in Scheme.
 212  */
 213
 214 SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
 215             (SCM port),
 216             "Read a newline-terminated line from @var{port}, allocating storage as\n"
 217             "necessary.  The newline terminator (if any) is removed from the string,\n"
 218             "and a pair consisting of the line and its delimiter is returned.  The\n"
 219             "delimiter may be either a newline or the @var{eof-object}; if\n"
 220             "@code{%read-line} is called at the end of file, it returns the pair\n"
 221             "@code{(#<eof> . #<eof>)}.")
 222 #define FUNC_NAME s_scm_read_line
 223 {
 224   scm_port *pt;
 225   char *s;
 226   int slen;
 227   SCM line, term;
 228
 229   if (SCM_UNBNDP (port))
 230     port = scm_cur_inp;
 231   SCM_VALIDATE_OPINPORT (1,port);
 232
 233   pt = SCM_PTAB_ENTRY (port);
 234   if (pt->rw_active == SCM_PORT_WRITE)
 235     scm_ptobs[SCM_PTOBNUM (port)].flush (port);
 236
 237   s = (char *) scm_do_read_line (port, &slen);
 238
 239   if (s == NULL)
 240     term = line = SCM_EOF_VAL;
 241   else
 242     {
 243       if (s[slen-1] == '\n')
 244         {
 245           term = SCM_MAKE_CHAR ('\n');
 246           s[slen-1] = '\0';
 247           line = scm_take_str (s, slen-1);
 248           scm_done_malloc (-1);
 249           SCM_INCLINE (port);
 250         }
 251       else
 252         {
 253           /* Fix: we should check for eof on the port before assuming this. */
 254           term = SCM_EOF_VAL;
 255           line = scm_take_str (s, slen);
 256           SCM_COL (port) += slen;
 257         }
 258     }
 259
 260   if (pt->rw_random)
 261     pt->rw_active = SCM_PORT_READ;
 262
 263   return scm_cons (line, term);
 264 }
 265 #undef FUNC_NAME
 266
 267 SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0,
 268             (SCM obj, SCM port),
 269             "Display @var{obj} and a newline character to @var{port}.  If @var{port}\n"
 270             "is not specified, @code{(current-output-port)} is used.  This function\n"
 271             "is equivalent to:\n\n"
 272             "@smalllisp\n"
 273             "(display obj [port])\n"
 274             "(newline [port])\n"
 275             "@end smalllisp")
 276 #define FUNC_NAME s_scm_write_line
 277 {
 278   scm_display (obj, port);
 279   return scm_newline (port);
 280 }
 281 #undef FUNC_NAME
 282
 283 void
 284 scm_init_rdelim (void)
 285 {
 286   SCM rdelim_module = scm_make_module (scm_read_0str ("(ice-9 rdelim)"));
 287   SCM old_module = scm_select_module (rdelim_module);
 288
 289 #ifndef SCM_MAGIC_SNARFER
 290 #include "libguile/rdelim.x"
 291 #endif
 292
 293   scm_select_module (old_module);
 294
 295 #if DEBUG_DEPRECATED == 0
 296   {
 297     const char expr[] = "\
 298 (define-module (guile) :use-module (ice-9 rdelim))\
 299 (define-module (guile-user) :use-module (ice-9 rdelim))";
 300
 301     scm_eval_string (scm_makfromstr (expr, (sizeof expr) - 1, 0));
 302   }
 303   scm_select_module (old_module);
 304 #endif
 305 }
 306
 307 /*
 308   Local Variables:
 309   c-file-style: "gnu"
 310   End:
 311 */