request for review: Doing direct file I/O in Emacs Lisp

[John Wiegley]

The following patch implements a file-handle interface for Emacs Lisp,
which allows files to be directly opened and read/written to without
an intervening buffer.  Eshell can now use this, for example, to
greatly speed up output redirection (by several orders of magnitude).

It is a simple interface that reads in strings, given a length, and
writes strings by examining their length:

  (let ((handle (file-handle-open "/tmp/some-file" "w")))
    (file-handle-write handle "Test data\n")
    (file-handle-close handle)

    (setq handle (file-handle-open "/tmp/some-file" "r"))
    (message (file-handle-read handle 128))
    (file-handle-close handle))

Please post comments here, or mail them to address@hidden

Thanks,
  John

----------------------------------------------------------------------
Index: src/ChangeLog
===================================================================
RCS file: /cvsroot/emacs/emacs/src/ChangeLog,v
retrieving revision 1.3671
diff -w -U3 -r1.3671 ChangeLog
--- src/ChangeLog       10 May 2004 04:15:14 -0000      1.3671
+++ src/ChangeLog       10 May 2004 05:51:30 -0000
@@ -3,6 +3,26 @@
        * fns.c (count_combining): Delete it.
        (concat): Don't check combining bytes.
 
+2004-05-09  John Wiegley  <address@hidden>
+
+       * lisp.h (enum pvec_type): Added PVEC_FILE_HANDLE type.  Added
+       Lisp_File_Handle structure, and several macros for dealing with
+       these types.
+
+       * fileio.c: Implemented several new functions: file-handle-p,
+       file-handle-open, file-handle-close, file-handle-read,
+       file-handle-write.
+       (syms_of_fileio): Declare these routines to the lisp interpretor.
+
+       * data.c: Added global Qfile_handle.
+       (Ftype_of): Check for file handles.
+       (syms_of_data): Intern the symbol "file-handle".
+       (syms_of_data): Setup the variable Qfile_handle.
+
+       * alloc.c (enum mem_type): Added MEM_TYPE_FILE_HANDLE.
+       (allocate_file_handle): New routine for allocating file handle
+       objects.
+
 2004-05-09  Jason Rumney  <address@hidden>
 
        * w32fns.c (Vw32_ansi_code_page): New Lisp variable.
Index: src/alloc.c
===================================================================
RCS file: /cvsroot/emacs/emacs/src/alloc.c,v
retrieving revision 1.333
diff -w -U3 -r1.333 alloc.c
--- src/alloc.c 26 Apr 2004 21:42:49 -0000      1.333
+++ src/alloc.c 10 May 2004 05:51:35 -0000
@@ -291,6 +291,7 @@
   MEM_TYPE_VECTOR,
   MEM_TYPE_PROCESS,
   MEM_TYPE_HASH_TABLE,
+  MEM_TYPE_FILE_HANDLE,
   MEM_TYPE_FRAME,
   MEM_TYPE_WINDOW
 };
@@ -2558,6 +2559,21 @@
     v->contents[i] = Qnil;
 
   return (struct Lisp_Hash_Table *) v;
+}
+
+
+struct Lisp_File_Handle *
+allocate_file_handle ()
+{
+  EMACS_INT len = VECSIZE (struct Lisp_File_Handle);
+  struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FILE_HANDLE);
+  EMACS_INT i;
+
+  for (i = 0; i < len; ++i)
+    v->contents[i] = Qnil;
+  v->size = len;
+
+  return (struct Lisp_File_Handle *) v;
 }
 
 
Index: src/data.c
===================================================================
RCS file: /cvsroot/emacs/emacs/src/data.c,v
retrieving revision 1.239
diff -w -U3 -r1.239 data.c
--- src/data.c  9 May 2004 00:49:06 -0000       1.239
+++ src/data.c  10 May 2004 05:51:49 -0000
@@ -93,7 +93,7 @@
 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
 Lisp_Object Qprocess;
 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
-static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
+static Lisp_Object Qchar_table, Qbool_vector, Qhash_table, Qfile_handle;
 static Lisp_Object Qsubrp, Qmany, Qunevalled;
 
 static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object));
@@ -243,6 +243,8 @@
        return Qframe;
       if (GC_HASH_TABLE_P (object))
        return Qhash_table;
+      if (GC_FILE_HANDLEP (object))
+       return Qfile_handle;
       return Qvector;
 
     case Lisp_Float:
@@ -3227,6 +3229,7 @@
   Qchar_table = intern ("char-table");
   Qbool_vector = intern ("bool-vector");
   Qhash_table = intern ("hash-table");
+  Qfile_handle = intern ("file-handle");
 
   staticpro (&Qinteger);
   staticpro (&Qsymbol);
@@ -3246,6 +3249,7 @@
   staticpro (&Qchar_table);
   staticpro (&Qbool_vector);
   staticpro (&Qhash_table);
+  staticpro (&Qfile_handle);
 
   defsubr (&Sindirect_variable);
   defsubr (&Sinteractive_form);
Index: src/fileio.c
===================================================================
RCS file: /cvsroot/emacs/emacs/src/fileio.c,v
retrieving revision 1.503
diff -w -U3 -r1.503 fileio.c
--- src/fileio.c        4 May 2004 19:23:31 -0000       1.503
+++ src/fileio.c        10 May 2004 05:51:50 -0000
@@ -6365,6 +6365,152 @@
 }
 
 
+DEFUN ("file-handle-p", Ffile_handle_p, Sfile_handle_p, 1, 1, 0,
+       doc: /* Return t if OBJECT is a direct file handle.  */)
+     (object)
+     Lisp_Object object;
+{
+  if (FILE_HANDLEP (object))
+    return Qt;
+  return Qnil;
+}
+
+
+DEFUN ("file-handle-open", Ffile_handle_open, Sfile_handle_open,
+       2, 2, 0,
+       doc: /* Open a file handle for direct reading/writing. */)
+     (path, mode)
+     Lisp_Object path, mode;
+{
+  FILE *stream;
+  Lisp_Object handle, lispstream;
+  struct Lisp_File_Handle *lh;
+
+  if (! STRINGP (path) || ! STRINGP (mode))
+    return Qnil;
+
+  if (! Ffile_exists_p (path))
+    return Qnil;
+
+  stream = fopen(SDATA (path), SDATA (mode));
+  if (! stream)
+    return Qnil;
+
+  lh = allocate_file_handle ();
+
+  /* Arrange to close that file whether or not we get an error.
+     Also reset auto_saving to 0.  */
+  lispstream = Fcons (Qnil, Qnil);
+  XSETCARFASTINT (lispstream, (EMACS_UINT)stream >> 16);
+  XSETCDRFASTINT (lispstream, (EMACS_UINT)stream & 0xffff);
+
+  lh->handle = lispstream;
+
+  XSETFILE_HANDLE (handle, lh);
+  xassert (FILE_HANDLEP (handle));
+  xassert (XFILE_HANDLE (handle) == lh);
+
+  return handle;
+}
+
+DEFUN ("file-handle-close", Ffile_handle_close, Sfile_handle_close,
+       1, 1, 0,
+       doc: /* Close a direct file handle. */)
+     (handle)
+     Lisp_Object handle;
+{
+  FILE *stream;
+  Lisp_Object lispstream;
+  struct Lisp_File_Handle *lh;
+
+  if (! FILE_HANDLEP (handle))
+    return Qnil;
+
+  lh = XFILE_HANDLE(handle);
+
+  lispstream = lh->handle;
+  if (! CONSP(lispstream))
+    return Qnil;
+
+  stream = (FILE *) (XFASTINT (XCAR (lispstream)) << 16 |
+                    XFASTINT (XCDR (lispstream)));
+  lh->handle = Qnil;
+  if (! stream)
+    return Qnil;
+
+  fclose(stream);
+
+  return Qt;
+}
+
+DEFUN ("file-handle-read", Ffile_handle_read, Sfile_handle_read,
+       2, 2, 0,
+       doc: /* Close a direct file handle. */)
+     (handle, length)
+     Lisp_Object handle, length;
+{
+  FILE *stream;
+  Lisp_Object lispstream, data;
+  struct Lisp_File_Handle *lh;
+  unsigned char *buf;
+  int read;
+
+  if (! FILE_HANDLEP (handle))
+    return Qnil;
+
+  lh = XFILE_HANDLE(handle);
+
+  lispstream = lh->handle;
+  if (! CONSP(lispstream))
+    return Qnil;
+
+  stream = (FILE *) (XFASTINT (XCAR (lispstream)) << 16 |
+                    XFASTINT (XCDR (lispstream)));
+  if (! stream)
+    return Qnil;
+
+  buf = (unsigned char *) alloca (XFASTINT (length));
+  data = make_string (buf, XFASTINT (length));
+  read = fread(SDATA (data), 1, XFASTINT (length), stream);
+  if (read != XFASTINT (length))
+    return Fsubstring (data, make_number (0), make_number (read));
+
+  return data;
+}
+
+DEFUN ("file-handle-write", Ffile_handle_write, Sfile_handle_write,
+       2, 2, 0,
+       doc: /* Close a direct file handle. */)
+     (handle, data)
+     Lisp_Object handle, data;
+{
+  FILE *stream;
+  Lisp_Object lispstream;
+  struct Lisp_File_Handle *lh;
+  int wrote;
+
+  if (! FILE_HANDLEP (handle))
+    return Qnil;
+
+  lh = XFILE_HANDLE(handle);
+
+  lispstream = lh->handle;
+  if (! CONSP(lispstream))
+    return Qnil;
+
+  stream = (FILE *) (XFASTINT (XCAR (lispstream)) << 16 |
+                    XFASTINT (XCDR (lispstream)));
+  if (! stream)
+    return Qnil;
+
+  wrote = fwrite(SDATA (data), 1, SCHARS (data), stream);
+  if (wrote != SCHARS (data))
+    return Qnil;
+
+  return Qt;
+}
+
+
 void
 init_fileio_once ()
 {
@@ -6678,6 +6824,12 @@
 
   defsubr (&Sread_file_name_internal);
   defsubr (&Sread_file_name);
+
+  defsubr (&Sfile_handle_p);
+  defsubr (&Sfile_handle_open);
+  defsubr (&Sfile_handle_close);
+  defsubr (&Sfile_handle_read);
+  defsubr (&Sfile_handle_write);
 
 #ifdef unix
   defsubr (&Sunix_sync);
Index: src/lisp.h
===================================================================
RCS file: /cvsroot/emacs/emacs/src/lisp.h,v
retrieving revision 1.489
diff -w -U3 -r1.489 lisp.h
--- src/lisp.h  26 Apr 2004 21:26:17 -0000      1.489
+++ src/lisp.h  10 May 2004 05:51:54 -0000
@@ -267,7 +267,8 @@
   PVEC_BOOL_VECTOR = 0x10000,
   PVEC_BUFFER = 0x20000,
   PVEC_HASH_TABLE = 0x40000,
-  PVEC_TYPE_MASK = 0x7fe00
+  PVEC_FILE_HANDLE = 0x80000,
+  PVEC_TYPE_MASK = 0xffe00
 
 #if 0 /* This is used to make the value of PSEUDOVECTOR_FLAG available to
         GDB.  It doesn't work on OS Alpha.  Moved to a variable in
@@ -513,6 +514,16 @@
 #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
 #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
 
+struct Lisp_File_Handle
+  {
+    EMACS_INT size;
+    struct Lisp_Vector *v_next;
+    Lisp_Object handle;
+};
+
+#define XSETFILE_HANDLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FILE_HANDLE))
+#define XFILE_HANDLE(a) ((struct Lisp_File_Handle *) XPNTR (a))
+
 /* Convenience macros for dealing with Lisp arrays.  */
 
 #define AREF(ARRAY, IDX)       XVECTOR ((ARRAY))->contents[IDX]
@@ -1421,6 +1432,8 @@
 #define GC_BOOL_VECTOR_P(x) GC_PSEUDOVECTORP (x, PVEC_BOOL_VECTOR)
 #define FRAMEP(x) PSEUDOVECTORP (x, PVEC_FRAME)
 #define GC_FRAMEP(x) GC_PSEUDOVECTORP (x, PVEC_FRAME)
+#define FILE_HANDLEP(x) PSEUDOVECTORP (x, PVEC_FILE_HANDLE)
+#define GC_FILE_HANDLEP(x) GC_PSEUDOVECTORP (x, PVEC_FILE_HANDLE)
 
 #define SUB_CHAR_TABLE_P(x) (CHAR_TABLE_P (x) && NILP (XCHAR_TABLE (x)->top))
 
@@ -2447,6 +2460,7 @@
 extern struct Lisp_Vector *allocate_vector P_ ((EMACS_INT));
 extern struct Lisp_Vector *allocate_other_vector P_ ((EMACS_INT));
 extern struct Lisp_Hash_Table *allocate_hash_table P_ ((void));
+extern struct Lisp_File_Handle *allocate_file_handle P_ ((void));
 extern struct window *allocate_window P_ ((void));
 extern struct frame *allocate_frame P_ ((void));
 extern struct Lisp_Process *allocate_process P_ ((void));
Index: src/print.c
===================================================================
RCS file: /cvsroot/emacs/emacs/src/print.c,v
retrieving revision 1.199
diff -w -U3 -r1.199 print.c
--- src/print.c 26 Apr 2004 21:56:26 -0000      1.199
+++ src/print.c 10 May 2004 05:51:57 -0000
@@ -1872,6 +1872,10 @@
          strout (buf, -1, -1, printcharfun, 0);
          PRINTCHAR ('>');
        }
+      else if (FILE_HANDLEP (obj))
+       {
+         strout ("#<file-handle>", -1, -1, printcharfun, 0);
+       }
       else if (BUFFERP (obj))
        {
          if (NILP (XBUFFER (obj)->name))
Index: lisp/eshell/esh-io.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/eshell/esh-io.el,v
retrieving revision 1.8
diff -w -U3 -r1.8 esh-io.el
--- lisp/eshell/esh-io.el       1 Sep 2003 15:45:23 -0000       1.8
+++ lisp/eshell/esh-io.el       10 May 2004 05:51:57 -0000
@@ -260,6 +260,10 @@
 
    ;; If we were redirecting to a file, save the file and close the
    ;; buffer.
+   ((and (fboundp 'file-handle-p)
+        (file-handle-p target))
+    (file-handle-close target))
+
    ((markerp target)
     (let ((buf (marker-buffer target)))
       (when buf                         ; somebody's already killed it!
@@ -337,6 +341,11 @@
         (if (nth 2 redir)
             (funcall (nth 1 redir) mode)
           (nth 1 redir))
+       (if (fboundp 'file-handle-open)
+          (cond ((eq mode 'overwrite)
+                 (file-handle-open target "w"))
+                ((eq mode 'append)
+                 (file-handle-open target "a")))
        (let* ((exists (get-file-buffer target))
              (buf (find-file-noselect target t)))
         (with-current-buffer buf
@@ -348,7 +357,7 @@
                  (erase-buffer))
                 ((eq mode 'append)
                  (goto-char (point-max))))
-          (point-marker))))))
+            (point-marker)))))))
    ((or (bufferp target)
        (and (boundp 'eshell-buffer-shorthand)
             (symbol-value 'eshell-buffer-shorthand)
@@ -461,6 +470,11 @@
   "Insert OBJECT into TARGET.
 Returns what was actually sent, or nil if nothing was sent."
   (cond
+   ((and (fboundp 'file-handle-p)
+        (file-handle-p target))
+    (setq object (eshell-stringify object))
+    (file-handle-write target object))
+
    ((functionp target)
     (funcall target object))