libguile/strports.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 \f
  20
  21 #if HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include "libguile/_scm.h"
  26
  27 #include <stdio.h>
  28 #ifdef HAVE_UNISTD_H
  29 #include <unistd.h>
  30 #endif
  31
  32 #include "libguile/unif.h"
  33 #include "libguile/eval.h"
  34 #include "libguile/ports.h"
  35 #include "libguile/read.h"
  36 #include "libguile/root.h"
  37 #include "libguile/strings.h"
  38 #include "libguile/modules.h"
  39 #include "libguile/validate.h"
  40 #include "libguile/deprecation.h"
  41
  42 #include "libguile/strports.h"
  43
  44 #ifdef HAVE_STRING_H
  45 #include <string.h>
  46 #endif
  47
  48 \f
  49
  50 /* {Ports - string ports}
  51  *
  52  */
  53
  54 /* NOTES:
  55    write_buf/write_end point to the ends of the allocated string.
  56    read_buf/read_end in principle point to the part of the string which
  57    has been written to, but this is only updated after a flush.
  58    read_pos and write_pos in principle should be equal, but this is only true
  59    when rw_active is SCM_PORT_NEITHER.
  60 */
  61
  62 scm_t_bits scm_tc16_strport;
  63
  64
  65 static int
  66 stfill_buffer (SCM port)
  67 {
  68   scm_t_port *pt = SCM_PTAB_ENTRY (port);
  69
  70   if (pt->read_pos >= pt->read_end)
  71     return EOF;
  72   else
  73     return scm_return_first_int (*pt->read_pos, port);
  74 }
  75
  76 /* change the size of a port's string to new_size.  this doesn't
  77    change read_buf_size.  */
  78 static void
  79 st_resize_port (scm_t_port *pt, off_t new_size)
  80 {
  81   SCM old_stream = SCM_PACK (pt->stream);
  82   SCM new_stream = scm_allocate_string (new_size);
  83   unsigned long int old_size = SCM_STRING_LENGTH (old_stream);
  84   unsigned long int min_size = min (old_size, new_size);
  85   unsigned long int i;
  86
  87   off_t index = pt->write_pos - pt->write_buf;
  88
  89   pt->write_buf_size = new_size;
  90
  91   for (i = 0; i != min_size; ++i)
  92     SCM_STRING_CHARS (new_stream) [i] = SCM_STRING_CHARS (old_stream) [i];
  93
  94   /* reset buffer. */
  95   {
  96     pt->stream = SCM_UNPACK (new_stream);
  97     pt->read_buf = pt->write_buf = SCM_STRING_UCHARS (new_stream);
  98     pt->read_pos = pt->write_pos = pt->write_buf + index;
  99     pt->write_end = pt->write_buf + pt->write_buf_size;
 100     pt->read_end = pt->read_buf + pt->read_buf_size;
 101   }
 102 }
 103
 104 /* amount by which write_buf is expanded.  */
 105 #define SCM_WRITE_BLOCK 80
 106
 107 /* ensure that write_pos < write_end by enlarging the buffer when
 108    necessary.  update read_buf to account for written chars.  */
 109 static void
 110 st_flush (SCM port)
 111 {
 112   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 113
 114   if (pt->write_pos == pt->write_end)
 115     {
 116       st_resize_port (pt, pt->write_buf_size + SCM_WRITE_BLOCK);
 117     }
 118   pt->read_pos = pt->write_pos;
 119   if (pt->read_pos > pt->read_end)
 120     {
 121       pt->read_end = (unsigned char *) pt->read_pos;
 122       pt->read_buf_size = pt->read_end - pt->read_buf;
 123     }
 124   pt->rw_active = SCM_PORT_NEITHER;
 125 }
 126
 127 static void
 128 st_write (SCM port, const void *data, size_t size)
 129 {
 130   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 131   const char *input = (char *) data;
 132
 133   while (size > 0)
 134     {
 135       int space = pt->write_end - pt->write_pos;
 136       int write_len = (size > space) ? space : size;
 137
 138       memcpy ((char *) pt->write_pos, input, write_len);
 139       pt->write_pos += write_len;
 140       size -= write_len;
 141       input += write_len;
 142       if (write_len == space)
 143         st_flush (port);
 144     }
 145 }
 146
 147 static void
 148 st_end_input (SCM port, int offset)
 149 {
 150   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 151
 152   if (pt->read_pos - pt->read_buf < offset)
 153     scm_misc_error ("st_end_input", "negative position", SCM_EOL);
 154
 155   pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset);
 156   pt->rw_active = SCM_PORT_NEITHER;
 157 }
 158
 159 static off_t
 160 st_seek (SCM port, off_t offset, int whence)
 161 {
 162   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 163   off_t target;
 164
 165   if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR)
 166     /* special case to avoid disturbing the unread-char buffer.  */
 167     {
 168       if (pt->read_buf == pt->putback_buf)
 169         {
 170           target = pt->saved_read_pos - pt->saved_read_buf
 171             - (pt->read_end - pt->read_pos);
 172         }
 173       else
 174         {
 175           target = pt->read_pos - pt->read_buf;
 176         }
 177     }
 178   else
 179     /* all other cases.  */
 180     {
 181       if (pt->rw_active == SCM_PORT_WRITE)
 182         st_flush (port);
 183
 184       if (pt->rw_active == SCM_PORT_READ)
 185         scm_end_input (port);
 186
 187       switch (whence)
 188         {
 189         case SEEK_CUR:
 190           target = pt->read_pos - pt->read_buf + offset;
 191           break;
 192         case SEEK_END:
 193           target = pt->read_end - pt->read_buf + offset;
 194           break;
 195         default: /* SEEK_SET */
 196           target = offset;
 197           break;
 198         }
 199
 200       if (target < 0)
 201         scm_misc_error ("st_seek", "negative offset", SCM_EOL);
 202
 203       if (target >= pt->write_buf_size)
 204         {
 205           if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG))
 206             {
 207               if (target > pt->write_buf_size)
 208                 {
 209                   scm_misc_error ("st_seek",
 210                                   "seek past end of read-only strport",
 211                                   SCM_EOL);
 212                 }
 213             }
 214           else
 215             {
 216               st_resize_port (pt, target + (target == pt->write_buf_size
 217                                             ? SCM_WRITE_BLOCK
 218                                             : 0));
 219             }
 220         }
 221       pt->read_pos = pt->write_pos = pt->read_buf + target;
 222       if (pt->read_pos > pt->read_end)
 223         {
 224           pt->read_end = (unsigned char *) pt->read_pos;
 225           pt->read_buf_size = pt->read_end - pt->read_buf;
 226         }
 227     }
 228   return target;
 229 }
 230
 231 static void
 232 st_truncate (SCM port, off_t length)
 233 {
 234   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 235
 236   if (length > pt->write_buf_size)
 237     st_resize_port (pt, length);
 238
 239   pt->read_buf_size = length;
 240   pt->read_end = pt->read_buf + length;
 241   if (pt->read_pos > pt->read_end)
 242     pt->read_pos = pt->read_end;
 243
 244   if (pt->write_pos > pt->read_end)
 245     pt->write_pos = pt->read_end;
 246 }
 247
 248 SCM
 249 scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
 250 {
 251   SCM z;
 252   scm_t_port *pt;
 253   size_t str_len;
 254
 255   SCM_ASSERT (SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller);
 256   SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG1, caller);
 257   str_len = SCM_STRING_LENGTH (str);
 258   if (SCM_INUM (pos) > str_len)
 259     scm_out_of_range (caller, pos);
 260   if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
 261     scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
 262
 263   SCM_DEFER_INTS;
 264   z = scm_new_port_table_entry (scm_tc16_strport);
 265   pt = SCM_PTAB_ENTRY(z);
 266   SCM_SETSTREAM (z, SCM_UNPACK (str));
 267   SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes);
 268   pt->write_buf = pt->read_buf = SCM_STRING_UCHARS (str);
 269   pt->read_pos = pt->write_pos = pt->read_buf + SCM_INUM (pos);
 270   pt->write_buf_size = pt->read_buf_size = str_len;
 271   pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
 272
 273   pt->rw_random = 1;
 274
 275   SCM_ALLOW_INTS;
 276
 277   /* ensure write_pos is writable. */
 278   if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
 279     st_flush (z);
 280   return z;
 281 }
 282
 283 /* create a new string from a string port's buffer.  */
 284 SCM scm_strport_to_string (SCM port)
 285 {
 286   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 287   SCM str;
 288
 289   if (pt->rw_active == SCM_PORT_WRITE)
 290     st_flush (port);
 291
 292   str = scm_mem2string ((char *) pt->read_buf, pt->read_buf_size);
 293   scm_remember_upto_here_1 (port);
 294   return str;
 295 }
 296
 297 SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
 298             (SCM obj, SCM printer),
 299             "Return a Scheme string obtained by printing @var{obj}.\n"
 300             "Printing function can be specified by the optional second\n"
 301             "argument @var{printer} (default: @code{write}).")
 302 #define FUNC_NAME s_scm_object_to_string
 303 {
 304   SCM str, port;
 305
 306   if (!SCM_UNBNDP (printer))
 307     SCM_VALIDATE_PROC (2, printer);
 308
 309   str = scm_allocate_string (0);
 310   port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME);
 311
 312   if (SCM_UNBNDP (printer))
 313     scm_write (obj, port);
 314   else
 315     scm_call_2 (printer, obj, port);
 316
 317   return scm_strport_to_string (port);
 318 }
 319 #undef FUNC_NAME
 320
 321 SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
 322            (SCM proc),
 323             "Calls the one-argument procedure @var{proc} with a newly created output\n"
 324             "port.  When the function returns, the string composed of the characters\n"
 325             "written into the port is returned.")
 326 #define FUNC_NAME s_scm_call_with_output_string
 327 {
 328   SCM p;
 329
 330   p = scm_mkstrport (SCM_INUM0,
 331                      scm_make_string (SCM_INUM0, SCM_UNDEFINED),
 332                      SCM_OPN | SCM_WRTNG,
 333                      FUNC_NAME);
 334   scm_call_1 (proc, p);
 335
 336   return scm_strport_to_string (p);
 337 }
 338 #undef FUNC_NAME
 339
 340 SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
 341            (SCM string, SCM proc),
 342             "Calls the one-argument procedure @var{proc} with a newly\n"
 343             "created input port from which @var{string}'s contents may be\n"
 344             "read.  The value yielded by the @var{proc} is returned.")
 345 #define FUNC_NAME s_scm_call_with_input_string
 346 {
 347   SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME);
 348   return scm_call_1 (proc, p);
 349 }
 350 #undef FUNC_NAME
 351
 352 SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
 353             (SCM str),
 354             "Take a string and return an input port that delivers characters\n"
 355             "from the string. The port can be closed by\n"
 356             "@code{close-input-port}, though its storage will be reclaimed\n"
 357             "by the garbage collector if it becomes inaccessible.")
 358 #define FUNC_NAME s_scm_open_input_string
 359 {
 360   SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME);
 361   return p;
 362 }
 363 #undef FUNC_NAME
 364
 365 SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
 366             (void),
 367             "Return an output port that will accumulate characters for\n"
 368             "retrieval by @code{get-output-string}. The port can be closed\n"
 369             "by the procedure @code{close-output-port}, though its storage\n"
 370             "will be reclaimed by the garbage collector if it becomes\n"
 371             "inaccessible.")
 372 #define FUNC_NAME s_scm_open_output_string
 373 {
 374   SCM p;
 375
 376   p = scm_mkstrport (SCM_INUM0,
 377                      scm_make_string (SCM_INUM0, SCM_UNDEFINED),
 378                      SCM_OPN | SCM_WRTNG,
 379                      FUNC_NAME);
 380   return p;
 381 }
 382 #undef FUNC_NAME
 383
 384 SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
 385             (SCM port),
 386             "Given an output port created by @code{open-output-string},\n"
 387             "return a string consisting of the characters that have been\n"
 388             "output to the port so far.")
 389 #define FUNC_NAME s_scm_get_output_string
 390 {
 391   SCM_VALIDATE_OPOUTSTRPORT (1, port);
 392   return scm_strport_to_string (port);
 393 }
 394 #undef FUNC_NAME
 395
 396
 397 /* Given a null-terminated string EXPR containing a Scheme expression
 398    read it, and return it as an SCM value. */
 399 SCM
 400 scm_c_read_string (const char *expr)
 401 {
 402   SCM port = scm_mkstrport (SCM_INUM0,
 403                             scm_makfrom0str (expr),
 404                             SCM_OPN | SCM_RDNG,
 405                             "scm_c_read_string");
 406   SCM form;
 407
 408   /* Read expressions from that port; ignore the values.  */
 409   form = scm_read (port);
 410
 411   scm_close_port (port);
 412   return form;
 413 }
 414
 415 /* Given a null-terminated string EXPR containing Scheme program text,
 416    evaluate it, and return the result of the last expression evaluated.  */
 417 SCM
 418 scm_c_eval_string (const char *expr)
 419 {
 420   return scm_eval_string (scm_makfrom0str (expr));
 421 }
 422
 423 SCM
 424 scm_c_eval_string_in_module (const char *expr, SCM module)
 425 {
 426   return scm_eval_string_in_module (scm_makfrom0str (expr), module);
 427 }
 428
 429
 430 static SCM
 431 inner_eval_string (void *data)
 432 {
 433   SCM port = (SCM)data;
 434   SCM form;
 435   SCM ans = SCM_UNSPECIFIED;
 436
 437   /* Read expressions from that port; ignore the values.  */
 438   while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
 439     ans = scm_primitive_eval_x (form);
 440
 441   /* Don't close the port here; if we re-enter this function via a
 442      continuation, then the next time we enter it, we'll get an error.
 443      It's a string port anyway, so there's no advantage to closing it
 444      early.  */
 445
 446   return ans;
 447 }
 448
 449 SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
 450             (SCM string, SCM module),
 451             "Evaluate @var{string} as the text representation of a Scheme\n"
 452             "form or forms, and return whatever value they produce.\n"
 453             "Evaluation takes place in the given module, or the current\n"
 454             "module when no module is given.\n"
 455             "While the code is evaluated, the given module is made the\n"
 456             "current one.  The current module is restored when this\n"
 457             "procedure returns.")
 458 #define FUNC_NAME s_scm_eval_string_in_module
 459 {
 460   SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
 461                             FUNC_NAME);
 462   if (SCM_UNBNDP (module))
 463     module = scm_current_module ();
 464   else
 465     SCM_VALIDATE_MODULE (2, module);
 466   return scm_c_call_with_current_module (module,
 467                                          inner_eval_string, (void *)port);
 468 }
 469 #undef FUNC_NAME
 470
 471 SCM
 472 scm_eval_string (SCM string)
 473 {
 474   return scm_eval_string_in_module (string, SCM_UNDEFINED);
 475 }
 476
 477 static scm_t_bits
 478 scm_make_stptob ()
 479 {
 480   scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
 481
 482   scm_set_port_mark        (tc, scm_markstream);
 483   scm_set_port_end_input   (tc, st_end_input);
 484   scm_set_port_flush       (tc, st_flush);
 485   scm_set_port_seek        (tc, st_seek);
 486   scm_set_port_truncate    (tc, st_truncate);
 487
 488   return tc;
 489 }
 490
 491 void
 492 scm_init_strports ()
 493 {
 494   scm_tc16_strport = scm_make_stptob ();
 495
 496 #include "libguile/strports.x"
 497 }
 498
 499
 500 /*
 501   Local Variables:
 502   c-file-style: "gnu"
 503   End:
 504 */