Path: utzoo!utgpu!news-server.csri.toronto.edu!bonnie.concordia.ca!thunder.mcrcim.mcgill.edu!snorkelwacker.mit.edu!usc!sdd.hp.com!ken From: ken@sdd.hp.com (Ken Stone) Newsgroups: comp.lang.perl Subject: lockf mods Message-ID: <1991Jan31.203029.12599@sdd.hp.com> Date: 31 Jan 91 20:30:29 GMT Organization: Hewlett Packard, San Diego Division Lines: 293 A while back I heard several people asking about lockf for perl. Yea you certainly >can< do it with fcntl(2) but its kind of a pain if your used to having lockf at your disposal. So here is a patch that should drop into 3.0@41 or 3.0@44 and along with it is a new member of the test suite to test it out !! If anybody else thinks this is great ... maybe Larry would consider it for 4.0 .... please ??? -- Ken # This is a shell archive. Remove anything before this line, # then unpack it by saving it in a file and typing "sh file". # # Wrapped by Source Hacker on Mon Jan 14 14:21:05 1991 # # This archive contains: # lockf.patches op.lockf # LANG=""; export LANG PATH=/bin:/usr/bin:$PATH; export PATH echo x - lockf.patches cat >lockf.patches <<'@EOF' *** perl.3.0/arg.h Wed Nov 14 08:36:06 1990 --- perl.3.0.patch41.virgin/arg.h Wed Nov 14 08:28:42 1990 *************** *** 315,322 **** #define O_FTCTIME 265 #define O_WAITPID 266 #define O_ALARM 267 ! #define O_LOCKF 268 ! #define MAXO 269 #ifndef DOINIT extern char *opname[]; --- 315,321 ---- #define O_FTCTIME 265 #define O_WAITPID 266 #define O_ALARM 267 ! #define MAXO 268 #ifndef DOINIT extern char *opname[]; *************** *** 590,597 **** "FTCTIME", "WAITPID", "ALARM", ! "LOCKF", ! "269" }; #endif --- 589,595 ---- "FTCTIME", "WAITPID", "ALARM", ! "268" }; #endif *************** *** 990,996 **** A(1,0,0), /* FTCTIME */ A(1,1,0), /* WAITPID */ A(1,0,0), /* ALARM */ - A(1,1,1), /* LOCKF */ 0 }; #undef A --- 988,993 ---- *** perl.3.0/config_h.SH Wed Nov 14 10:27:19 1990 --- perl.3.0.patch41.virgin/config_h.SH Wed Nov 14 08:28:43 1990 *************** *** 160,171 **** */ #$d_flock FLOCK /**/ - /* LOCKF: - * This symbol, if defined, indicates that the lockf() routine is - * available to do file locking. - */ - #$d_lockf LOCKF /**/ - /* GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple --- 160,165 ---- *** perl.3.0/eval.c Wed Nov 14 08:52:42 1990 --- perl.3.0.patch41.virgin/eval.c Wed Nov 14 08:28:52 1990 *************** *** 1901,1930 **** str_set(str,"0 but true"); STABSET(str); break; - case O_LOCKF: - #ifdef LOCKF - if (maxarg <= 0) - stab = last_in_stab; - else if ((arg[1].arg_type & A_MASK) == A_WORD) - stab = arg[1].arg_ptr.arg_stab; - else - stab = stabent(str_get(st[1]),TRUE); - if (stab && stab_io(stab)) - fp = stab_io(stab)->ifp; - else - fp = Nullfp; - if (fp) { - argtype = (int)str_gnum(st[2]); - when = (long)str_gnum(st[3]); - value = (double)(lockf(fileno(fp),argtype,when) >= 0); - } - else - value = 0; - goto donumset; - #else - fatal("The lockf() function is unimplemented on this machine"); - break; - #endif case O_FLOCK: #ifdef FLOCK if (maxarg <= 0) --- 1901,1906 ---- *** perl.3.0/toke.c Wed Nov 14 08:38:11 1990 --- perl.3.0.patch41.virgin/toke.c Wed Nov 14 08:29:35 1990 *************** *** 953,960 **** FOP2(O_LISTEN); if (strEQ(d,"lstat")) FOP(O_LSTAT); - if (strEQ(d,"lockf")) - FOP3(O_LOCKF); break; case 'm': case 'M': if (s[1] == '\'') { --- 953,958 ---- *** perl.3.0/Configure Wed Nov 14 10:25:44 1990 --- perl.3.0.patch41.virgin/Configure Wed Nov 14 08:28:39 1990 *************** *** 114,120 **** d_fchown='' d_fcntl='' d_flock='' - d_lockf='' d_getgrps='' d_gethent='' d_getpgrp='' --- 114,119 ---- *************** *** 1708,1717 **** set flock d_flock eval $inlibc - : see if lockf exists - set lockf d_lockf - eval $inlibc - : see if getgroups exists set getgroups d_getgrps eval $inlibc --- 1707,1712 ---- *************** *** 2712,2718 **** d_fchown='$d_fchown' d_fcntl='$d_fcntl' d_flock='$d_flock' - d_lockf='$d_lockf' d_getgrps='$d_getgrps' d_gethent='$d_gethent' d_getpgrp='$d_getpgrp' --- 2707,2712 ---- *** perl.3.0/config_h.SH Wed Nov 14 10:27:19 1990 --- perl.3.0.patch41.virgin/config_h.SH Wed Nov 14 08:28:43 1990 *************** *** 160,171 **** */ #$d_flock FLOCK /**/ - /* LOCKF: - * This symbol, if defined, indicates that the lockf() routine is - * available to do file locking. - */ - #$d_lockf LOCKF /**/ - /* GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple --- 160,165 ---- *** perl.3.0/perl_man.2 Wed Nov 14 10:30:13 1990 --- perl.3.0.patch41.virgin/perl_man.2 Wed Nov 14 08:29:09 1990 *************** *** 650,660 **** Useful for constructing bitmaps for select(). If FILEHANDLE is an expression, the value is taken as the name of the filehandle. - .Ip "lockf(FILEHANDLE,FUNCTION,SIZE)" 8 4 - Calls lockf(2) on FILEHANDLE. - See manual page for lockf(2) for definition of OPERATION and SIZE. - Will produce a fatal error if used on a machine that doesn't implement - lockf(2). .Ip "flock(FILEHANDLE,OPERATION)" 8 4 Calls flock(2) on FILEHANDLE. See manual page for flock(2) for definition of OPERATION. --- 650,655 ---- @EOF chmod 666 lockf.patches echo x - op.lockf cat >op.lockf <<'@EOF' #!./perl # $Header$ sub lockftest { local($op, $size) = @_; local($got,*FOOBAR); if (fork() == 0) { open(FOOBAR,'op.lockf') || open(FOOBAR,'t/op.lockf') || exit -1; $got = lockf(FOOBAR, $op, $size); print "# child($$) got $got ($!)\n"; close(FOOBAR); exit $got; } wait; return($? >> 8); } print "1..8\n"; open(FOO,'op.lockf') || open(FOO,'t/op.lockf') || die "Can't open op.lockf"; # Lock it $got = lockf(FOO, 1, 0); print "# parent($$) got $got ($!)\n"; print ($got ? "ok 1\n" : "not ok 1\n"); # Test after fork $got = &lockftest(2, 0); print ((! $got) ? "ok 2\n" : "not ok 2\n"); # Unlock $got = lockf(FOO, 0, 0); print "# parent($$) got $got ($!)\n"; print ($got ? "ok 3\n" : "not ok 3\n"); # Now try test after fork $got = &lockftest(2, 0); print ($got ? "ok 4\n" : "not ok 4\n"); # Non overlapping locked regions $got = seek(FOO, 10, 0); if ($got) { $got = lockf(FOO, 1, 10); print "# parent($$) got $got ($!)\n"; print ($got ? "ok 5\n" : "not ok 5\n"); $got = &lockftest(2, 10); print ($got ? "ok 6\n" : "not ok 6\n"); lockf(FOO, 0, 10); } else { print "seek failed ($!)\n"; print "not ok 5\n"; print "not ok 6\n"; } # Overlapping locked regions $got = seek(FOO, 10, 0); if ($got) { $got = lockf(FOO, 1, 10); print "# parent($$) got $got ($!)\n"; print ($got ? "ok 7\n" : "not ok 7\n"); $got = &lockftest(2, 15); print ((! $got) ? "ok 8\n" : "not ok 8\n"); lockf(FOO, 0, 10); } else { print "seek failed ($!)\n"; print "not ok 7\n"; print "not ok 8\n"; } close(FOOBAR); @EOF chmod 755 op.lockf exit 0