Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 220 lines (187 sloc) 4.688 kb
09eee3c @gfx Initial commit from CPAN version 0.70
authored
1 /*
2 :flock - open with flock()
3 :creat - open with O_CREAT
4 :excl - open with O_EXCL
5
6 */
7
8 #include "perlioutil.h"
9 #include "perlioflock.h"
10
23fb955 @gfx Use PERL_MODE_MAX (in perlio.c) for the length of mode
authored
11 #define PERLIOUTIL_MODE_MAX 8 /* PERL_MODE_MAX in perlio.c */
12
09eee3c @gfx Initial commit from CPAN version 0.70
authored
13 static IV
14 PerlIOFlock_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
15 PerlIO_funcs* tab){
16
17 int lock_mode;
18 int fd;
19 int ret;
20
21 PERL_UNUSED_ARG(mode);
22 PERL_UNUSED_ARG(tab);
23
24 if(!PerlIOValid(fp)){
25 SETERRNO(EBADF, SS_IVCHAN);
26 return -1;
27 }
28
29 lock_mode = IOLflag(fp, PERLIO_F_CANWRITE) ? LOCK_EX : LOCK_SH;
30
31 if(arg && SvOK(arg)){
32 const char* const blocking = SvPV_nolen_const(arg);
33
34 if(strEQ(blocking, "blocking")){
35 /* noop */
36 }
37 else if(strEQ(blocking, "non-blocking")
38 || strEQ(blocking, "LOCK_NB")){
39 lock_mode |= LOCK_NB;
40 }
41 else{
42 Perl_croak(aTHX_ "Unrecognized :flock handler '%s' "
43 "(it must be 'blocking' or 'non-blocking')",
44 blocking);
45 }
46 }
47
48 fd = PerlIO_fileno(fp);
49 if(fd == -1){ /* :scalar, :dir, etc. */
50 return 0; /* success */
51 }
52
53 PerlIO_flush(fp);
54 ret = PerlLIO_flock(fd, lock_mode);
55
56 PerlIO_debug(STRINGIFY(FLOCK) "(%d, %s) -> %d\n", fd,
57 ( lock_mode == (LOCK_SH) ? "LOCK_SH"
58 : lock_mode == (LOCK_SH|LOCK_NB) ? "LOCK_SH|LOCK_NB"
59 : lock_mode == (LOCK_EX) ? "LOCK_EX"
60 : lock_mode == (LOCK_EX|LOCK_NB) ? "LOCK_EX|LOCK_NB"
61 : "(UNKNOWN)" ),
62 ret);
63
64 return ret;
65 }
66
67 IV
68 PerlIOUtil_useless_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
69 PerlIO_funcs* tab){
70 PERL_UNUSED_ARG(fp);
71 PERL_UNUSED_ARG(mode);
72 PERL_UNUSED_ARG(arg);
73
74 PerlIOUtil_warnif(aTHX_ packWARN(WARN_LAYER), "Too late for %s layer", tab->name);
75
76 return -1;
77 }
78
79 static PerlIO*
80 PerlIOUtil_open_with_flags(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
81 const char* mode, int fd, int imode, int perm,
82 PerlIO* f, int narg, SV** args, int flags){
23fb955 @gfx Use PERL_MODE_MAX (in perlio.c) for the length of mode
authored
83 char numeric_mode[PERLIOUTIL_MODE_MAX]; /* [I#]? [wra]\+? [tb] \0 */
09eee3c @gfx Initial commit from CPAN version 0.70
authored
84
85 PERL_UNUSED_ARG(self);
d0a8d2b @gfx Add test code
authored
86 assert( mode != NULL );
09eee3c @gfx Initial commit from CPAN version 0.70
authored
87
88 if(mode[0] != IoTYPE_NUMERIC){
89 numeric_mode[0] = IoTYPE_NUMERIC; /* as sysopen() */
90
06e86cc @tokuhirom fixed invalid usage of Copy().see perlapi.pod.
tokuhirom authored
91 Copy(mode, &numeric_mode[1], strlen(mode) + 1 /* '\0' */, char);
09eee3c @gfx Initial commit from CPAN version 0.70
authored
92 mode = &numeric_mode[0];
93 }
94
95 if(!imode){
96 imode = PerlIOUnix_oflags(mode);
97 perm = 0666;
98 }
99
100 return PerlIOUtil_openn(aTHX_ NULL, layers, n, mode,
101 fd, imode | flags,
102 perm, f, narg, args);
103 }
104
105 static PerlIO*
106 PerlIOCreat_open(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
107 const char* mode, int fd, int imode, int perm,
108 PerlIO* f, int narg, SV** args){
109
110 return PerlIOUtil_open_with_flags(aTHX_ self, layers, n, mode, fd, imode,
111 perm, f, narg, args, O_CREAT);
112 }
113
114 static PerlIO*
115 PerlIOExcl_open(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
116 const char* mode, int fd, int imode, int perm,
117 PerlIO* f, int narg, SV** args){
118
119 return PerlIOUtil_open_with_flags(aTHX_ self, layers, n, mode, fd, imode,
120 perm, f, narg, args, O_EXCL);
121 }
122
123
124 /* :flock */
125 PERLIO_FUNCS_DECL(PerlIO_flock) = {
126 sizeof(PerlIO_funcs),
127 "flock",
128 0, /* size */
129 PERLIO_K_DUMMY, /* kind */
130 PerlIOFlock_pushed,
131 NULL, /* popped */
132 NULL, /* open */
133 NULL, /* binmode */
134 NULL, /* arg */
135 NULL, /* fileno */
136 NULL, /* dup */
137 NULL, /* read */
138 NULL, /* unread */
139 NULL, /* write */
140 NULL, /* seek */
141 NULL, /* tell */
142 NULL, /* close */
143 NULL, /* flush */
144 NULL, /* fill */
145 NULL, /* eof */
146 NULL, /* error */
147 NULL, /* clearerr */
148 NULL, /* setlinebuf */
149 NULL, /* get_base */
150 NULL, /* bufsiz */
151 NULL, /* get_ptr */
152 NULL, /* get_cnt */
153 NULL /* set_ptrcnt */
154 };
155
156 /* :creat */
157 PERLIO_FUNCS_DECL(PerlIO_creat) = {
158 sizeof(PerlIO_funcs),
159 "creat",
160 0, /* size */
161 PERLIO_K_DUMMY, /* kind */
162 PerlIOUtil_useless_pushed,
163 NULL, /* popped */
164 PerlIOCreat_open,
165 NULL, /* binmode */
166 NULL, /* arg */
167 NULL, /* fileno */
168 NULL, /* dup */
169 NULL, /* read */
170 NULL, /* unread */
171 NULL, /* write */
172 NULL, /* seek */
173 NULL, /* tell */
174 NULL, /* close */
175 NULL, /* flush */
176 NULL, /* fill */
177 NULL, /* eof */
178 NULL, /* error */
179 NULL, /* clearerr */
180 NULL, /* setlinebuf */
181 NULL, /* get_base */
182 NULL, /* bufsiz */
183 NULL, /* get_ptr */
184 NULL, /* get_cnt */
185 NULL /* set_ptrcnt */
186 };
187
188 /* :excl */
189 PERLIO_FUNCS_DECL(PerlIO_excl) = {
190 sizeof(PerlIO_funcs),
191 "excl",
192 0, /* size */
193 PERLIO_K_DUMMY, /* kind */
194 PerlIOUtil_useless_pushed,
195 NULL, /* popped */
196 PerlIOExcl_open,
197 NULL, /* binmode */
198 NULL, /* arg */
199 NULL, /* fileno */
200 NULL, /* dup */
201 NULL, /* read */
202 NULL, /* unread */
203 NULL, /* write */
204 NULL, /* seek */
205 NULL, /* tell */
206 NULL, /* close */
207 NULL, /* flush */
208 NULL, /* fill */
209 NULL, /* eof */
210 NULL, /* error */
211 NULL, /* clearerr */
212 NULL, /* setlinebuf */
213 NULL, /* get_base */
214 NULL, /* bufsiz */
215 NULL, /* get_ptr */
216 NULL, /* get_cnt */
217 NULL /* set_ptrcnt */
218 };
219
Something went wrong with that request. Please try again.