Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

220 lines (187 sloc) 4.688 kb
/*
:flock - open with flock()
:creat - open with O_CREAT
:excl - open with O_EXCL
*/
#include "perlioutil.h"
#include "perlioflock.h"
#define PERLIOUTIL_MODE_MAX 8 /* PERL_MODE_MAX in perlio.c */
static IV
PerlIOFlock_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
PerlIO_funcs* tab){
int lock_mode;
int fd;
int ret;
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(tab);
if(!PerlIOValid(fp)){
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
lock_mode = IOLflag(fp, PERLIO_F_CANWRITE) ? LOCK_EX : LOCK_SH;
if(arg && SvOK(arg)){
const char* const blocking = SvPV_nolen_const(arg);
if(strEQ(blocking, "blocking")){
/* noop */
}
else if(strEQ(blocking, "non-blocking")
|| strEQ(blocking, "LOCK_NB")){
lock_mode |= LOCK_NB;
}
else{
Perl_croak(aTHX_ "Unrecognized :flock handler '%s' "
"(it must be 'blocking' or 'non-blocking')",
blocking);
}
}
fd = PerlIO_fileno(fp);
if(fd == -1){ /* :scalar, :dir, etc. */
return 0; /* success */
}
PerlIO_flush(fp);
ret = PerlLIO_flock(fd, lock_mode);
PerlIO_debug(STRINGIFY(FLOCK) "(%d, %s) -> %d\n", fd,
( lock_mode == (LOCK_SH) ? "LOCK_SH"
: lock_mode == (LOCK_SH|LOCK_NB) ? "LOCK_SH|LOCK_NB"
: lock_mode == (LOCK_EX) ? "LOCK_EX"
: lock_mode == (LOCK_EX|LOCK_NB) ? "LOCK_EX|LOCK_NB"
: "(UNKNOWN)" ),
ret);
return ret;
}
IV
PerlIOUtil_useless_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
PerlIO_funcs* tab){
PERL_UNUSED_ARG(fp);
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
PerlIOUtil_warnif(aTHX_ packWARN(WARN_LAYER), "Too late for %s layer", tab->name);
return -1;
}
static PerlIO*
PerlIOUtil_open_with_flags(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
const char* mode, int fd, int imode, int perm,
PerlIO* f, int narg, SV** args, int flags){
char numeric_mode[PERLIOUTIL_MODE_MAX]; /* [I#]? [wra]\+? [tb] \0 */
PERL_UNUSED_ARG(self);
assert( mode != NULL );
if(mode[0] != IoTYPE_NUMERIC){
numeric_mode[0] = IoTYPE_NUMERIC; /* as sysopen() */
Copy(mode, &numeric_mode[1], strlen(mode) + 1 /* '\0' */, char);
mode = &numeric_mode[0];
}
if(!imode){
imode = PerlIOUnix_oflags(mode);
perm = 0666;
}
return PerlIOUtil_openn(aTHX_ NULL, layers, n, mode,
fd, imode | flags,
perm, f, narg, args);
}
static PerlIO*
PerlIOCreat_open(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
const char* mode, int fd, int imode, int perm,
PerlIO* f, int narg, SV** args){
return PerlIOUtil_open_with_flags(aTHX_ self, layers, n, mode, fd, imode,
perm, f, narg, args, O_CREAT);
}
static PerlIO*
PerlIOExcl_open(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
const char* mode, int fd, int imode, int perm,
PerlIO* f, int narg, SV** args){
return PerlIOUtil_open_with_flags(aTHX_ self, layers, n, mode, fd, imode,
perm, f, narg, args, O_EXCL);
}
/* :flock */
PERLIO_FUNCS_DECL(PerlIO_flock) = {
sizeof(PerlIO_funcs),
"flock",
0, /* size */
PERLIO_K_DUMMY, /* kind */
PerlIOFlock_pushed,
NULL, /* popped */
NULL, /* open */
NULL, /* binmode */
NULL, /* arg */
NULL, /* fileno */
NULL, /* dup */
NULL, /* read */
NULL, /* unread */
NULL, /* write */
NULL, /* seek */
NULL, /* tell */
NULL, /* close */
NULL, /* flush */
NULL, /* fill */
NULL, /* eof */
NULL, /* error */
NULL, /* clearerr */
NULL, /* setlinebuf */
NULL, /* get_base */
NULL, /* bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL /* set_ptrcnt */
};
/* :creat */
PERLIO_FUNCS_DECL(PerlIO_creat) = {
sizeof(PerlIO_funcs),
"creat",
0, /* size */
PERLIO_K_DUMMY, /* kind */
PerlIOUtil_useless_pushed,
NULL, /* popped */
PerlIOCreat_open,
NULL, /* binmode */
NULL, /* arg */
NULL, /* fileno */
NULL, /* dup */
NULL, /* read */
NULL, /* unread */
NULL, /* write */
NULL, /* seek */
NULL, /* tell */
NULL, /* close */
NULL, /* flush */
NULL, /* fill */
NULL, /* eof */
NULL, /* error */
NULL, /* clearerr */
NULL, /* setlinebuf */
NULL, /* get_base */
NULL, /* bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL /* set_ptrcnt */
};
/* :excl */
PERLIO_FUNCS_DECL(PerlIO_excl) = {
sizeof(PerlIO_funcs),
"excl",
0, /* size */
PERLIO_K_DUMMY, /* kind */
PerlIOUtil_useless_pushed,
NULL, /* popped */
PerlIOExcl_open,
NULL, /* binmode */
NULL, /* arg */
NULL, /* fileno */
NULL, /* dup */
NULL, /* read */
NULL, /* unread */
NULL, /* write */
NULL, /* seek */
NULL, /* tell */
NULL, /* close */
NULL, /* flush */
NULL, /* fill */
NULL, /* eof */
NULL, /* error */
NULL, /* clearerr */
NULL, /* setlinebuf */
NULL, /* get_base */
NULL, /* bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL /* set_ptrcnt */
};
Jump to Line
Something went wrong with that request. Please try again.