Re: (fcntl fd F_GETLK ...) from Guile

[Mike Gran <spk121@yahoo.com>]

[-- Attachment #1: Type: text/plain, Size: 899 bytes --]

Kaloian-

--- Kaloian Doganov <kaloian@doganov.org> wrote:

> Is there a way to use fcntl's F_GETLK command from Guile?  According
> to the docs [1], only the following commands are available:
> 

I put together something.  I've attached the more important source
files here for reference, but, the buildable files are in 
http://lonelycactus.com/getlk-0.0.tar.gz

For me, it does "./configure && make && make install" on Linux, but
fails on Cygwin.  Cygwin fails because I don't know how to do DLLs.

Here's what it does on my machine.  Your mileage may vary.

bash-3.1$ guile
guile> (use-modules (getlk))
guile> (define fd (open-output-file "blammo"))
guile> (define lk (fcntl-lk fd F_SETLKW (list F_WRLCK SEEK_SET 0 0
(getpid))))
guile> lk
(1 0 0 0 11415)
guile> (set! lk (fcntl-lk fd F_SETLK (list F_UNLCK SEEK_SET 0 0
(getpid))))
guile> lk
(2 0 0 0 11415)
guile>
  
Good luck.

-- Mike Gran




[-- Attachment #2: 1659791818-getlk.c --]
[-- Type: text/plain, Size: 2993 bytes --]

#include <config.h>

#include <fcntl.h>
#include <libguile.h>
#include <stdio.h>
#include <unistd.h>

#ifdef DLL_EXPORT
#define API __attribute__ ((dllexport, cdecl))
#else
#define API
#endif

SCM getlk_fcntl_lk_fdes (SCM s_fdes, SCM s_cmd, SCM s_list) API;
void getlk_init_getlk (void) API;

SCM s_f_getlk;
SCM s_f_setlk;
SCM s_f_setlkw;

SCM s_f_rdlck;
SCM s_f_wrlck;
SCM s_f_unlck;

SCM getlk_fcntl_lk_fdes(SCM s_fdes, SCM s_cmd, SCM s_list)
{
  int rv;
  int fdes;
  struct flock lock;
  SCM l_type;
  SCM l_whence;
  SCM l_start;
  SCM l_len;
  SCM l_pid;

  SCM_ASSERT (scm_is_integer(s_fdes),
	      s_fdes, SCM_ARG1, "fcntl-lk-fdes");
  SCM_ASSERT ( scm_is_integer (s_cmd), s_cmd, SCM_ARG2, 
	       "fcntl-lk-fdes");
  SCM_ASSERT ( scm_is_true (scm_list_p (s_list)), s_list, SCM_ARG3, 
	       "fcntl-lk-fdes");

  fdes = scm_to_int (s_fdes);
  
  l_type = scm_list_ref (s_list, scm_from_int (0));
  l_whence = scm_list_ref (s_list, scm_from_int (1));
  l_start = scm_list_ref (s_list, scm_from_int (2));
  l_len = scm_list_ref (s_list, scm_from_int (3));
  l_pid = scm_list_ref (s_list, scm_from_int (4));
  
  lock.l_type = scm_to_short (l_type);
  lock.l_whence = scm_to_short (l_whence);
  if (SIZEOF_OFF_T == 4)
    {
      lock.l_start = scm_to_int32 (l_start);
      lock.l_len = scm_to_int32 (l_len);
    }
  else if (SIZEOF_OFF_T == 8)
    {
      lock.l_start = scm_to_int64 (l_start);
      lock.l_len = scm_to_int64 (l_len);
    }
  else
    abort ();
  if (SIZEOF_PID_T == 4)
    {
      lock.l_pid = scm_to_int32 (l_pid);
    }
  else
    abort ();

  
  rv = fcntl (fdes, scm_to_int (s_cmd), &lock);
  if (rv == -1)
    {
      scm_syserror ("fcntl-lk-fdes");
    }

  l_type = scm_from_short (lock.l_type);
  l_whence = scm_from_short (lock.l_whence);
  if (SIZEOF_OFF_T == 4)
    {
      l_start = scm_from_int32 (lock.l_start);
      l_len = scm_from_int32 (lock.l_len);
    }
  else if (SIZEOF_OFF_T == 8)
    {
      l_start = scm_from_int64 (lock.l_start);
      l_len = scm_from_int64 (lock.l_len);
    }
  else
    {
      printf ("aborting at %s %d", __FILE__, __LINE__);
      abort ();
    }

  if (SIZEOF_PID_T == 4)
    {
      l_pid = scm_from_int32 (lock.l_pid);
    }
  else 
    {
      printf ("aborting at %s %d", __FILE__, __LINE__);
      abort ();
    }

  return scm_list_5 (l_type, l_whence, l_start, l_len, l_pid);
}

void
getlk_init_getlk ()
{
  scm_c_define_gsubr ("fcntl-lk-fdes", 3, 0, 0, getlk_fcntl_lk_fdes);
  s_f_getlk = scm_permanent_object (scm_c_define ("F_GETLK", scm_from_int (F_GETLK)));
  s_f_setlk = scm_permanent_object (scm_c_define ("F_SETLK", scm_from_int (F_SETLK)));
  s_f_setlkw = scm_permanent_object (scm_c_define ("F_SETLKW", scm_from_int (F_SETLKW)));

  s_f_rdlck = scm_permanent_object (scm_c_define ("F_RDLCK", scm_from_int (F_RDLCK)));
  s_f_wrlck = scm_permanent_object (scm_c_define ("F_WRLCK", scm_from_int (F_WRLCK)));
  s_f_unlck = scm_permanent_object (scm_c_define ("F_UNLCK", scm_from_int (F_UNLCK)));

}

[-- Attachment #3: 1271041479-getlk.scm.in --]
[-- Type: application/octet-stream, Size: 356 bytes --]

;; -*- Mode: scheme -*-

(define-module (getlk)
  #:export (fcntl-lk
	    F_GETLK
	    F_SETLK
	    F_SETLKW
	    F_RDLCK
	    F_WRLCK
	    F_UNLCK))


(define (fcntl-lk fdes cmd list)
  (if (port? fdes)
      (fcntl-lk-fdes (port->fdes fdes) cmd list)
      (fcntl-lk-fdes fdes cmd list)))


(load-extension "XXlibdirXX/libguile-getlk" "getlk_init_getlk")

[-- Attachment #4: Type: text/plain, Size: 140 bytes --]

_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-user