[PATCH: ext/Fcntl] pack/unpack for struct flock

Using fcntl locking (explicitly, as opposed to via flock emulation) is
rather tricky to do portably, since:

 * the struct changes with -Duselargefiles, and
 * without -Duse64bitint it's not possible to use 'q' with pack/unpack.

A simple patch for Fcntl is included to provide a function to
pack/unpack flock structures.

    my $s = struct_flock F_WRLCK, SEEK_SET, 0, 42;
    my ($type, $whence, $start, $len, $pid) = struct_flock $s;

Note: the implentation as given will have problems for 64bit start/len
values (suggestions?), but should suffice for most uses.

--bod

diff -Naur perl-5.8.7.orig/ext/Fcntl/Fcntl.pm perl-5.8.7/ext/Fcntl/Fcntl.pm
--- perl-5.8.7.orig/ext/Fcntl/Fcntl.pm	2003-08-19 06:46:27.000000000 +1000
+++ perl-5.8.7/ext/Fcntl/Fcntl.pm	2006-01-11 18:02:19.000000000 +1100
@@ -17,11 +17,6 @@
 and your native C compiler.  This means that it has a 
 far more likely chance of getting the numbers right.
 
-=head1 NOTE
-
-Only C<#define> symbols get translated; you must still correctly
-pack up your own arguments to pass as args for locking functions, etc.
-
 =head1 EXPORTED SYMBOLS
 
 By default your system's F_* and O_* constants (eg, F_DUPFD and
@@ -53,6 +48,22 @@
 
 See L<perlfunc/stat> about the S_I* constants.
 
+=head1 LOCKING
+
+flock structures may be packed and unpacked using B<struct_flock>:
+
+=over 4
+
+=item struct_flock TYPE,WHENCE,START,LEN[,PID]
+
+Pack structure (scalar context)
+
+=item struct_flock PACKED
+
+Unpack (list context).
+
+=back
+
 =cut
 
 our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD);
@@ -185,6 +196,7 @@
 	_S_IFMT S_IFREG S_IFDIR S_IFLNK
 	&S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO
 	&S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE
+	struct_flock
 );
 # Named groups of exports
 %EXPORT_TAGS = (
@@ -219,6 +231,11 @@
 sub S_ISWHT    { ( $_[0] & _S_IFMT() ) == S_IFWHT()   }
 sub S_ISENFMT  { ( $_[0] & _S_IFMT() ) == S_IFENFMT() }
 
+sub struct_flock
+{
+    wantarray ? Fcntl::unpack_struct_flock(@_) : Fcntl::pack_struct_flock(@_);
+}
+
 sub AUTOLOAD {
     (my $constname = $AUTOLOAD) =~ s/.*:://;
     die "&Fcntl::constant not defined" if $constname eq 'constant';
diff -Naur perl-5.8.7.orig/ext/Fcntl/Fcntl.xs perl-5.8.7/ext/Fcntl/Fcntl.xs
--- perl-5.8.7.orig/ext/Fcntl/Fcntl.xs	2002-03-05 10:05:31.000000000 +1100
+++ perl-5.8.7/ext/Fcntl/Fcntl.xs	2006-01-11 17:21:52.000000000 +1100
@@ -37,4 +37,45 @@
 
 MODULE = Fcntl		PACKAGE = Fcntl
 
+SV *
+pack_struct_flock(l_type, l_whence, l_start, l_len, l_pid = 0)
+    short l_type
+    short l_whence
+    long l_start
+    long l_len
+    int l_pid
+
+  INIT:
+    struct flock f;
+    f.l_type = l_type;
+    f.l_whence = l_whence;
+    f.l_start = l_start;
+    f.l_len = l_len;
+    f.l_pid = l_pid;
+
+  CODE:
+    RETVAL = newSVpvn((void *) &f, sizeof(f));
+
+  OUTPUT:
+    RETVAL
+
+void
+unpack_struct_flock(packed)
+    SV *packed
+
+  INIT:
+    struct flock f;
+
+  PPCODE:
+    if (sv_len(packed) < sizeof(f))
+	XSRETURN_UNDEF;
+
+    Copy(SvPV_nolen(packed), &f, 1, struct flock);
+    EXTEND(SP, 5);
+    PUSHs(sv_2mortal(newSViv(f.l_type)));
+    PUSHs(sv_2mortal(newSViv(f.l_whence)));
+    PUSHs(sv_2mortal(newSViv(f.l_start)));
+    PUSHs(sv_2mortal(newSViv(f.l_len)));
+    PUSHs(sv_2mortal(newSViv(f.l_pid)));
+
 INCLUDE: const-xs.inc

• [PATCH: ext/Fcntl] pack/unpack for struct flock by Brendan O'Dea