Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/usocket-usocket-20250208033134/backend/sbcl.lisp

Kind	Covered	All	%
expression	0	592	0.0
branch	0	90	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: Common-Lisp -*-

2

3

;;;; See LICENSE for licensing information.

4

5

(in-package :usocket)

6

7

#+sbcl

8

(progn

9

#-win32

10

(defun get-host-name ()

11

(sb-unix:unix-gethostname))

12

13

;; we assume winsock has already been loaded, after all,

14

;; we already loaded sb-bsd-sockets and sb-alien

15

#+win32

16

(defun get-host-name ()

17

(sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))

18

(let ((result (sb-alien:alien-funcall

19

(sb-alien:extern-alien "gethostname"

20

                                              (sb-alien:function sb-alien:int

21

                                                                 (* sb-alien:char)

22

                                                                 sb-alien:int))

23

(sb-alien:cast buf (* sb-alien:char))

24

256)))

25

(when (= result 0)

26

(sb-alien:cast buf sb-alien:c-string))))))

27

28

#+(or mkcl (and ecl (not ecl-bytecmp)))

29

(progn

30

#-:wsock

31

(ffi:clines

32

"#include <errno.h>"

33

"#include <sys/socket.h>"

34

"#include <unistd.h>")

35

#+:wsock

36

(ffi:clines

37

"#ifndef FD_SETSIZE"

38

"#define FD_SETSIZE 1024"

39

"#endif"

40

"#include <winsock2.h>")

41

42

(ffi:clines

43

#+:msvc "#include <time.h>"

44

#-:msvc "#include <sys/time.h>"

45

"#include <ecl/ecl-inl.h>")

46

#|

47

#+:prefixed-api

48

(ffi:clines

49

"#define CONS(x, y) ecl_cons((x), (y))"

50

"#define MAKE_INTEGER(x) ecl_make_integer((x))")

51

#-:prefixed-api

52

(ffi:clines

53

"#define CONS(x, y) make_cons((x), (y))"

54

"#define MAKE_INTEGER(x) make_integer((x))")

55

|#

56

57

(defun cerrno ()

58

(ffi:c-inline () () :int

59

"errno" :one-liner t))

60

61

(defun fd-setsize ()

62

(ffi:c-inline () () :fixnum

63

"FD_SETSIZE" :one-liner t))

64

65

#+ecl

66

(defun fdset-alloc ()

67

(ffi:c-inline () () :pointer-void

68

"ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))

69

#+mkcl

70

(defun fdset-alloc ()

71

(ffi:c-inline () () :pointer-void

72

"mkcl_alloc_atomic(MKCL_ENV(), sizeof(fd_set))" :one-liner t))

73

74

(defun fdset-zero (fdset)

75

(ffi:c-inline (fdset) (:pointer-void) :void

76

"FD_ZERO((fd_set*)#0)" :one-liner t))

77

78

(defun fdset-set (fdset fd)

79

(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void

80

"FD_SET(#1,(fd_set*)#0)" :one-liner t))

81

82

(defun fdset-clr (fdset fd)

83

(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void

84

"FD_CLR(#1,(fd_set*)#0)" :one-liner t))

85

86

(defun fdset-fd-isset (fdset fd)

87

(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool

88

"FD_ISSET(#1,(fd_set*)#0)" :one-liner t))

89

90

(declaim (inline cerrno

91

fd-setsize

92

fdset-alloc

93

fdset-zero

94

fdset-set

95

fdset-clr

96

fdset-fd-isset))

97

98

#+ecl

99

(defun get-host-name ()

100

(ffi:c-inline

101

() () :object

102

"{ char *buf = (char *) ecl_alloc_atomic(257);

103

104

if (gethostname(buf,256) == 0)

105

@(return) = make_simple_base_string(buf);

106

else

107

@(return) = Cnil;

108

}" :one-liner nil :side-effects nil))

109

110

#+mkcl

111

(defun get-host-name ()

112

(ffi:c-inline

113

() () :object

114

"{ char *buf = (char *) mkcl_alloc_atomic(MKCL_ENV(),257);

115

116

if (gethostname(buf,256) == 0)

117

@(return) = mkcl_cstring_to_base_string(MKCL_ENV(), (buf));

118

else

119

@(return) = mk_cl_Cnil;

120

}" :one-liner nil :side-effects nil))

121

122

(defun read-select (wl to-secs &optional (to-musecs 0))

123

(let* ((sockets (wait-list-waiters wl))

124

(rfds (wait-list-%wait wl))

125

(max-fd (reduce #'(lambda (x y)

126

(let ((sy (sb-bsd-sockets:socket-file-descriptor

127

(socket y))))

128

(if (< x sy) sy x)))

129

(cdr sockets)

130

:initial-value (sb-bsd-sockets:socket-file-descriptor

131

(socket (car sockets))))))

132

(fdset-zero rfds)

133

(dolist (sock sockets)

134

(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor

135

(socket sock))))

136

(let ((count

137

(ffi:c-inline (to-secs to-musecs rfds max-fd)

138

(t :unsigned-int :pointer-void :int)

139

:int

140

#+ecl

141

"

142

int count;

143

struct timeval tv;

144

struct timeval tvs;

145

struct timeval tve;

146

unsigned long elapsed;

147

unsigned long remaining;

148

int retval = -1;

149

150

if (#0 != Cnil) {

151

tv.tv_sec = fixnnint(#0);

152

tv.tv_usec = #1;

153

}

154

remaining = ((tv.tv_sec*1000000) + tv.tv_usec);

155

156

do {

157

(void)gettimeofday(&tvs, NULL); // start time

158

159

retval = select(#3 + 1, (fd_set*)#2, NULL, NULL,

160

(#0 != Cnil) ? &tv : NULL);

161

162

if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) {

163

(void)gettimeofday(&tve, NULL); // end time

164

elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec);

165

remaining = remaining - elapsed;

166

                   if ( remaining < 0 ) {                     // already past timeout, just exit

167

retval = 0;

168

break;

169

}

170

171

tv.tv_sec = remaining / 1000000;

172

tv.tv_usec = remaining - (tv.tv_sec * 1000000);

173

}

174

175

} while ((retval < 0) && (errno == EINTR));

176

177

@(return) = retval;

178

"

179

#+mkcl

180

"

181

int count;

182

struct timeval tv;

183

struct timeval tvs;

184

struct timeval tve;

185

unsigned long elapsed;

186

unsigned long remaining;

187

int retval = -1;

188

189

if (#0 != mk_cl_Cnil) {

190

tv.tv_sec = mkcl_integer_to_word(MKCL_ENV(), #0);

191

tv.tv_usec = #1;

192

}

193

remaining = ((tv.tv_sec*1000000) + tv.tv_usec);

194

195

do {

196

(void)gettimeofday(&tvs, NULL); // start time

197

198

retval = select(#3 + 1, (fd_set*)#2, NULL, NULL,

199

(#0 != mk_cl_Cnil) ? &tv : NULL);

200

201

if ( (retval < 0) && (errno == EINTR) && (#0 != mk_cl_Cnil) ) {

202

(void)gettimeofday(&tve, NULL); // end time

203

elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec);

204

remaining = remaining - elapsed;

205

                   if ( remaining < 0 ) {                     // already past timeout, just exit

206

retval = 0;

207

break;

208

}

209

210

tv.tv_sec = remaining / 1000000;

211

tv.tv_usec = remaining - (tv.tv_sec * 1000000);

212

}

213

214

} while ((retval < 0) && (errno == EINTR));

215

216

@(return) = retval;

217

"

218

219

220

221

:one-liner nil)))

222

(cond

223

((= 0 count)

224

(values nil nil))

225

((< count 0)

226

;; check for EAGAIN; these should not err

227

(values nil (cerrno)))

228

(t

229

(dolist (sock sockets)

230

(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor

231

(socket sock)))

232

(setf (state sock) :READ))))))))

233

) ; progn

234

235

(defun map-socket-error (sock-err)

236

(map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))

237

238

(defparameter +sbcl-condition-map+

239

'((interrupted-error . interrupted-condition)

240

#+(or ecl mkcl clasp)

241

(sb-bsd-sockets::host-not-found-error . ns-host-not-found-error)))

242

243

(defparameter +sbcl-error-map+

244

`((sb-bsd-sockets:address-in-use-error . address-in-use-error)

245

(sb-bsd-sockets::no-address-error . address-not-available-error)

246

(sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error)

247

(sb-bsd-sockets:connection-refused-error . connection-refused-error)

248

(sb-bsd-sockets:invalid-argument-error . invalid-argument-error)

249

(sb-bsd-sockets:no-buffers-error . no-buffers-error)

250

(sb-bsd-sockets:operation-not-supported-error

251

. operation-not-supported-error)

252

(sb-bsd-sockets:operation-not-permitted-error

253

. operation-not-permitted-error)

254

(sb-bsd-sockets:protocol-not-supported-error

255

. protocol-not-supported-error)

256

#-(or ecl mkcl clasp)

257

(sb-bsd-sockets:unknown-protocol

258

. protocol-not-supported-error)

259

(sb-bsd-sockets:socket-type-not-supported-error

260

. socket-type-not-supported-error)

261

(sb-bsd-sockets:network-unreachable-error . network-unreachable-error)

262

(sb-bsd-sockets:operation-timeout-error . timeout-error)

263

#-(or ecl mkcl clasp)

264

(sb-sys:io-timeout . timeout-error)

265

#+sbcl (sb-ext:timeout . timeout-error)

266

267

;; learnt from fiveam (suggested by Anton Vodonosov) for early SBCL versions

268

#+#.(cl:if (cl:ignore-errors (cl:find-symbol "BROKEN-PIPE" "SB-INT"))

269

'(and) '(or))

270

(sb-int:broken-pipe . connection-aborted-error)

271

272

(sb-bsd-sockets:socket-error . ,#'map-socket-error)

273

274

;; Nameservice errors: mapped to unknown-error

275

#-(or ecl mkcl clasp)

276

(sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)

277

#-(or ecl mkcl clasp)

278

(sb-bsd-sockets:try-again-error . ns-try-again-error)

279

#-(or ecl mkcl clasp)

280

(sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))

281

282

;; this function servers as a general template for other backends

283

(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))

284

"Dispatch correct usocket condition."

285

(typecase condition

286

(serious-condition

287

(let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+)))

288

(usock-error (if (functionp usock-error)

289

(funcall usock-error condition)

290

usock-error)))

291

(declare (type symbol usock-error))

292

(when usock-error

293

(cond ((subtypep usock-error 'ns-error)

294

(error usock-error :socket socket :host-or-ip host-or-ip))

295

(t

296

(error usock-error :socket socket))))))

297

(condition

298

(let* ((usock-cond (cdr (assoc (type-of condition) +sbcl-condition-map+)))

299

(usock-cond (if (functionp usock-cond)

300

(funcall usock-cond condition)

301

usock-cond)))

302

(when usock-cond

303

(cond ((subtypep usock-cond 'ns-condition)

304

(signal usock-cond :socket socket :host-or-ip host-or-ip))

305

(t

306

(signal usock-cond :socket socket))))))))

307

308

;;; "The socket stream ends up with a bogus name as it is created before

309

;;; the socket is connected, making things harder to debug than they need

310

;;; to be." -- Nikodemus Siivola <nikodemus@random-state.net>

311

312

(defvar *dummy-stream*

313

(let ((stream (make-broadcast-stream)))

314

(close stream)

315

stream))

316

317

;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch

318

;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS

319

;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than

320

;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus@random-state.net>

321

322

#+(and sbcl (not win32))

323

(defmacro %with-timeout ((seconds timeout-form) &body body)

324

"Runs BODY as an implicit PROGN with timeout of SECONDS. If

325

timeout occurs before BODY has finished, BODY is unwound and

326

TIMEOUT-FORM is executed with its values returned instead.

327

328

Note that BODY is unwound asynchronously when a timeout occurs,

329

so unless all code executed during it -- including anything

330

down the call chain -- is asynch unwind safe, bad things will

331

happen. Use with care."

332

(let ((exec (gensym)) (unwind (gensym)) (timer (gensym))

333

(timeout (gensym)) (block (gensym)))

334

`(block ,block

335

(tagbody

336

(flet ((,unwind ()

337

(go ,timeout))

338

(,exec ()

339

,@body))

340

(declare (dynamic-extent #',exec #',unwind))

341

(let ((,timer (sb-ext:make-timer #',unwind)))

342

(sb-sys:without-interrupts

343

(unwind-protect

344

(progn

345

(sb-ext:schedule-timer ,timer ,seconds)

346

(return-from ,block

347

(sb-sys:with-local-interrupts

348

(,exec))))

349

(sb-ext:unschedule-timer ,timer)))))

350

,timeout

351

(return-from ,block ,timeout-form)))))

352

353

(defun get-hosts-by-name (name)

354

(with-mapped-conditions (nil name)

355

(multiple-value-bind (host4 host6)

356

(sb-bsd-sockets:get-host-by-name name)

357

(let ((addr4 (when host4

358

(sb-bsd-sockets::host-ent-addresses host4)))

359

(addr6 (when host6

360

(sb-bsd-sockets::host-ent-addresses host6))))

361

(append addr4 addr6)))))

362

363

364

;; determine if a socket condition indicates operation is in progress

365

(defun %socket-operation-condition-in-progress-p (condition)

366

#+sbcl ;; sbcl defines this condition (also for Windows?)

367

(typep condition 'sb-bsd-sockets:operation-in-progress) ;; errno 36

368

;;

369

#+(or ecl mkcl clasp) ; MKCL *might* work, no idea about clasp

370

;; we might expect sb-bsd-sockets in ECL to translate errno to BSD, but it does not.

371

;; on Darwin ECL seems to prefer error 35, which is EWOULDBLOCK, not 36

372

;; so we allow both

373

(and (typep condition 'sb-bsd-sockets::socket-error)

374

(member (sb-bsd-sockets::socket-error-errno condition) ;; have to use unexported symbol

375

'(#-linux 35 #-linux 36 ;; should cover darwin and any BSD

376

;; on ECL for Raspberry Pi (and others?) Linux EINPROGRESS=115 is

377

;; not translated correctly to BSD, so we allow code 115 too

378

#+linux 115

379

))))

380

381

;; determine if a socket condition indicates not-connected (yet) status

382

(defun %socket-operation-condition-not-connected-p (condition)

383

#+sbcl ;; sbcl defines this condition (also for Windows?)

384

(typep condition 'sb-bsd-sockets:not-connected-error) ;; errno 36

385

#+(or ecl mkcl clasp) ; MKCL *might* work, no idea about CLASP

386

;; we might expect sb-bsd-sockets in ECL to translate errno to BSD, but it does not.

387

(and (typep condition 'sb-bsd-sockets::socket-error)

388

(member (sb-bsd-sockets::socket-error-errno condition) ;; have to use unexported symbol

389

'(#-linux 57 ;; should cover darwin and any BSD

390

;; on ECL for Raspberry Pi (and others?) Linux ENOTCONN=107

391

#+linux 107))))

392

393

394

;; enable the new non-blocking socket method

395

(defparameter *socket-connect-nonblock-wait*

396

;; trust SBCL errno to be handled correctly in SB-BSD-SOCKETS on all platforms

397

   ;; ..except Windows: "EINTR (A non-blocking socket operation could not be completed immediately.)" (#106)

398

#+(and sbcl win32)

399

nil

400

#+(and sbcl (not win32))

401

t

402

;; trust that errno is done correctly above - how are BSD flavors marked in *features*?

403

#+(and (or ecl mkcl) (or darwin linux openbsd freebsd netbsd bsd))

404

t

405

;; for all other cases, we have no reason to think we handle errno correctly in

406

;; %socket-operation-condition-*

407

#+(or clasp

408

(and (or ecl mkcl) (not (or darwin linux openbsd freebsd netbsd bsd))))

409

nil)

410

411

(defun socket-connect-internal (host

412

                                 &key port (protocol :stream) (element-type 'character)

413

timeout

414

                                   ;; connection-timeout and read-timeout override

415

;; plain timeout

416

(connection-timeout nil conn-timeout-p)

417

(read-timeout nil read-timeout-p)

418

deadline (nodelay t nodelay-specified)

419

local-host local-port

420

&aux

421

(sockopt-tcp-nodelay-p

422

                                    (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))

423

(when (and (member :win32 *features*) (pathnamep host))

424

(unsupported 'unix-domain-socket 'Windows))

425

(when deadline (unsupported 'deadline 'socket-connect))

426

#+(or ecl mkcl clasp)

427

(when (and timeout #-clasp (not *socket-connect-nonblock-wait*))

428

(unsupported 'timeout 'socket-connect))

429

(when (and nodelay-specified

430

;; 20080802: ECL added this function to its sockets

431

;; package today. There's no guarantee the functions

432

;; we need are available, but we can make sure not to

433

;; call them if they aren't

434

(not (eq nodelay :if-supported))

435

(not sockopt-tcp-nodelay-p))

436

(unsupported 'nodelay 'socket-connect))

437

(when (eq nodelay :if-supported)

438

(setf nodelay t))

439

440

(let* ((read-timeout* (if read-timeout-p read-timeout timeout))

441

(conn-timeout* (if conn-timeout-p connection-timeout timeout))

442

(remote (and host (not (pathnamep host))

443

(car (get-hosts-by-name (host-to-hostname host)))))

444

(local (when local-host

445

(car (get-hosts-by-name (host-to-hostname local-host)))))

446

(ipv6 (or (and remote (= 16 (length remote)))

447

(and local (= 16 (length local)))))

448

(sock-type #+sbcl

449

(cond

450

#-win32((pathnamep host) 'sb-bsd-sockets:local-socket)

451

(ipv6 'sb-bsd-sockets:inet6-socket)

452

(t 'sb-bsd-sockets:inet-socket))

453

#+(or ecl mkcl clasp) 'sb-bsd-sockets:inet-socket)

454

(socket (make-instance sock-type

455

:type protocol

456

:protocol (case protocol

457

                                             (:stream #+sbcl(if (pathnamep host) 0 :tcp)

458

                                                      #+(or ecl mkcl clasp) :tcp)

459

(:datagram :udp))))

460

461

;; sb-bsd-sockets:socket-connect is apparently called as

462

;; (socket-connect socket remote-host remote-port) or

463

;; (socket-connect socket local-socket-address)

464

;; hence connect-args is constructed as follows

465

(connect-args (if (pathnamep host)

466

(list (uiop:unix-namestring host))

467

(list #+sbcl (if (and local (not (eq host *wildcard-host*)))

468

local

469

remote)

470

#+(or ecl mkcl clasp) (host-to-vector-quad host)

471

port)))

472

usocket

473

ok)

474

475

(unwind-protect

476

(progn

477

(ecase protocol

478

(:stream

479

;; If make a real socket stream before the socket is

480

;; connected, it gets a misleading name so supply a

481

;; dummy value to start with.

482

(setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))

483

;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol

484

;; to pass compilation on ECL without it.

485

(when (and nodelay sockopt-tcp-nodelay-p

486

                          (not (pathnamep host))) ; Unix domain sockets do not have this option

487

(setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))

488

(when (or local-host local-port)

489

(sb-bsd-sockets:socket-bind socket

490

(if ipv6

491

                                                 (or local (ipv6-host-to-vector "::0"))

492

                                                 (or local (host-to-vector-quad *wildcard-host*)))

493

                                             (or local-port *auto-port*)))

494

495

(with-mapped-conditions (usocket host)

496

                 (if *socket-connect-nonblock-wait* ;; global var to disable new connect timeout

497

;; case of new timeout code

498

(if conn-timeout*

499

                         (let ((initial-blocking-mode  (sb-bsd-sockets:non-blocking-mode socket)))

500

;; first connect

501

(progn

502

                             (setf (sb-bsd-sockets:non-blocking-mode socket) t) ;; non-blocking mode

503

(multiple-value-bind (retval err)

504

                                 (ignore-errors (apply #'sb-bsd-sockets:socket-connect (cons socket connect-args)))

505

                               ;; if the error generated is not EINPROGRESS then throw error

506

(when (and (not retval) err)

507

                                 (when (not (%socket-operation-condition-in-progress-p err))

508

(error err)))))

509

;; then loop/sleep until ready

510

(loop

511

;; start with very short wait time

512

with dt-sleep of-type double-float = 10d-6

513

with start-time of-type double-float

514

                                 = (/ (* 1d0 (get-internal-real-time)) internal-time-units-per-second)

515

with end-time of-type double-float

516

= (+ start-time (float conn-timeout* 1d0))

517

with current-time of-type double-float = start-time

518

do

519

                                  ;;(format t "TIME: ~A DT: ~,7F~%" current-time dt-sleep)

520

;; check if there is a peer on other end

521

(multiple-value-bind (peer err)

522

                                      (ignore-errors (sb-bsd-sockets:socket-peername socket))

523

                                    (cond (peer (return)) ;; socket has peer, so is connected

524

                                          ((and err ;; not 'not-connected' error, so it failed

525

                                                (not (%socket-operation-condition-not-connected-p err)))

526

(error err))))

527

(sleep dt-sleep)

528

                                  (setf current-time (/ (* 1d0 (get-internal-real-time))

529

                                                        internal-time-units-per-second))

530

531

(when (>= current-time end-time)

532

(error 'timeout-error))

533

534

;; Keep increasing sleep time in

535

;; 4 steps per decade but don't exceed the

536

;; end-time. Max is 0.1 sec.

537

                                  (setf dt-sleep (min (* dt-sleep #.(sqrt (sqrt 10d0)))

538

                                                      0.1d0  ;; but not more than 0.1 sec

539

                                                      (max (- end-time current-time) ;; but don't oversleep

540

                                                           10d-6))))

541

;; restore blocking mode

542

                           (setf (sb-bsd-sockets:non-blocking-mode socket) initial-blocking-mode))

543

;; no timeout case

544

                         (apply #'sb-bsd-sockets:socket-connect (cons socket connect-args)))

545

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

546

;; if not *socket-connect-nonblock-wait*, then use old timeout code

547

;; which uses interrupts on SBCL, and doesn't work on ECL

548

#+(and sbcl (not win32))

549

(labels ((connect ()

550

                                (apply #'sb-bsd-sockets:socket-connect (cons socket connect-args))))

551

(if timeout

552

(%with-timeout (timeout (error 'sb-ext:timeout)) (connect))

553

(connect)))

554

#+(or ecl mkcl clasp (and sbcl win32))

555

(apply #'sb-bsd-sockets:socket-connect (cons socket connect-args)))

556

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

557

558

;; Now that we're connected make the stream.

559

(setf (socket-stream usocket)

560

(sb-bsd-sockets:socket-make-stream socket

561

:input t :output t :buffering :full

562

:element-type element-type

563

:timeout read-timeout*

564

;; Robert Brown <robert.brown@gmail.com> said on Aug 4, 2011:

565

                         ;; ... This means that SBCL streams created by usocket have a true

566

                         ;; serve-events property.  When writing large amounts of data to several

567

                         ;; streams, the kernel will eventually stop accepting data from SBCL.

568

                         ;; When this happens, SBCL either waits for I/O to be possible on

569

                         ;; the file descriptor it's writing to or queues the data to be flushed later.

570

;; Because usocket streams specify serve-events as true, SBCL

571

                         ;; always queues.  Instead, it should wait for I/O to be available and

572

                         ;; write the remaining data to the socket.  That's what serve-events

573

;; equal to NIL gets you.

574

;;

575

                         ;; Nikodemus Siivola <nikodemus@random-state.net> said on Aug 8, 2011:

576

                         ;; It's set to T for purely historical reasons, and will soon change to

577

                         ;; NIL in SBCL. (The docstring has warned of T being a temporary default

578

                         ;; for as long as the :SERVE-EVENTS keyword argument has existed.)

579

:serve-events nil))))

580

(:datagram

581

(when (or local-host local-port)

582

(sb-bsd-sockets:socket-bind socket

583

(if ipv6

584

                                                 (or local (ipv6-host-to-vector "::0"))

585

                                                 (or local (host-to-vector-quad *wildcard-host*)))

586

                                             (or local-port *auto-port*)))

587

(setf usocket (make-datagram-socket socket))

588

(when (and host port)

589

(with-mapped-conditions (usocket)

590

(apply #'sb-bsd-sockets:socket-connect (cons socket connect-args))

591

(setf (connected-p usocket) t)))))

592

(setf ok t))

593

;; Clean up in case of an error.

594

(unless ok

595

(sb-bsd-sockets:socket-close socket :abort t)))

596

usocket))

597

598

(defun socket-listen-internal

599

(host &key port reuseaddress

600

(reuse-address nil reuse-address-supplied-p)

601

(backlog 5)

602

(element-type 'character))

603

(when (and (member :win32 *features*) (pathnamep host))

604

(unsupported 'unix-domain-socket 'Windows))

605

(let* (#+sbcl

606

(local (and host (not (pathnamep host))

607

(car (get-hosts-by-name (host-to-hostname host)))))

608

#+sbcl

609

(ipv6 (and local (= 16 (length local))))

610

(sock-type #+sbcl

611

(cond

612

#-win32((pathnamep host) 'sb-bsd-sockets:local-socket)

613

(ipv6 'sb-bsd-sockets:inet6-socket)

614

(t 'sb-bsd-sockets:inet-socket))

615

#+(or ecl mkcl clasp) 'sb-bsd-sockets:inet-socket)

616

(reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))

617

(sock (make-instance sock-type

618

:type :stream

619

:protocol (if (pathnamep host) 0 :tcp)))

620

(bind-args (if (pathnamep host)

621

(list (uiop:unix-namestring host))

622

(list #+sbcl (if (and local (not (eq host *wildcard-host*)))

623

local

624

                                          (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))

625

#+(or ecl mkcl clasp) (host-to-vector-quad host)

626

port))))

627

(handler-case

628

(with-mapped-conditions (nil host)

629

(setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress)

630

(apply #'sb-bsd-sockets:socket-bind (cons sock bind-args))

631

(sb-bsd-sockets:socket-listen sock backlog)

632

(make-stream-server-socket sock :element-type element-type))

633

(t (c)

634

;; Make sure we don't leak filedescriptors

635

(sb-bsd-sockets:socket-close sock)

636

(error c)))))

637

638

;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,

639

;;; instead of raising a condition. It's always possible for

640

;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket

641

;;; was detected to be ready: connection might be reset, for example.

642

;;;

643

;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to

644

;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton@sw4me.com>

645

646

(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)

647

(with-mapped-conditions (usocket)

648

(let ((socket (sb-bsd-sockets:socket-accept (socket usocket))))

649

(when socket

650

(prog1

651

(make-stream-socket

652

:socket socket

653

:stream (sb-bsd-sockets:socket-make-stream

654

socket

655

:input t :output t :buffering :full

656

:element-type (or element-type

657

(element-type usocket))))

658

659

;; next time wait for event again if we had EAGAIN/EINTR

660

;; or else we'd enter a tight loop of failed accepts

661

#+win32

662

(setf (%ready-p usocket) nil))))))

663

664

;; Sockets and their associated streams are modelled as

665

;; different objects. Be sure to close the stream (which

666

;; closes the socket too) when closing a stream-socket.

667

(defmethod socket-close ((usocket usocket))

668

(with-mapped-conditions (usocket)

669

(sb-bsd-sockets:socket-close (socket usocket))))

670

671

;; usocket leaks file descriptors on sb-int:broken-pipe conditions (#64)

672

;;

673

;; "If abort is true, an attempt is made to clean up any side effects of having

674

;; created stream. If stream performs output to a file that was created when

675

;; the stream was created, the file is deleted and any previously existing file

676

;; is not superseded. ... If abort is true and the stream is an output file stream,

677

;; its associated file might be deleted." (ANSI)

678

;;

679

;; adding (:abort t) fixes the potential leaks of socket fds.

680

(defmethod socket-close ((usocket stream-usocket))

681

(with-mapped-conditions (usocket)

682

(close (socket-stream usocket) :abort t)))

683

684

#+sbcl

685

(defmethod socket-shutdown ((usocket stream-usocket) direction)

686

(with-mapped-conditions (usocket)

687

(sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction)))

688

689

#+(or ecl mkcl)

690

(defmethod socket-shutdown ((usocket stream-usocket) direction)

691

(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))

692

(direction-flag (ecase direction

693

(:input 0)

694

(:output 1)

695

(:io 2))))

696

(unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int

697

"shutdown(#0, #1)" :one-liner t))

698

(error (map-errno-error (cerrno))))))

699

700

#+clasp

701

(defmethod socket-shutdown ((usocket stream-usocket) direction)

702

(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))

703

(direction-flag (ecase direction

704

(:input 0)

705

(:output 1)

706

(:io 2))))

707

(unless (zerop (sockets-internal:shutdown sock-fd direction-flag))

708

(error (map-errno-error (cerrno))))))

709

710

(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))

711

(let ((remote (when host

712

(car (get-hosts-by-name (host-to-hostname host))))))

713

(with-mapped-conditions (usocket host)

714

(let* ((s (socket usocket))

715

(dest (if (and host port) (list remote port) nil))

716

(real-buffer (if (zerop offset)

717

buffer

718

(subseq buffer offset (+ offset size)))))

719

(sb-bsd-sockets:socket-send s real-buffer size :address dest)))))

720

721

(defmethod socket-receive ((usocket datagram-usocket) buffer length

722

&key (element-type '(unsigned-byte 8)))

723

#+sbcl

724

(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer

725

(integer 0) ; size

726

(simple-array (unsigned-byte 8) (*)) ; host

727

(unsigned-byte 16) ; port

728

&optional))

729

(with-mapped-conditions (usocket)

730

(let ((s (socket usocket)))

731

(sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))

732

733

(defmethod get-local-name ((usocket usocket))

734

(sb-bsd-sockets:socket-name (socket usocket)))

735

736

(defmethod get-peer-name ((usocket stream-usocket))

737

(sb-bsd-sockets:socket-peername (socket usocket)))

738

739

(defmethod get-local-address ((usocket usocket))

740

(nth-value 0 (get-local-name usocket)))

741

742

(defmethod get-peer-address ((usocket stream-usocket))

743

(nth-value 0 (get-peer-name usocket)))

744

745

(defmethod get-local-port ((usocket usocket))

746

(nth-value 1 (get-local-name usocket)))

747

748

(defmethod get-peer-port ((usocket stream-usocket))

749

(nth-value 1 (get-peer-name usocket)))

750

751

(defun get-host-by-address (address)

752

(with-mapped-conditions (nil address)

753

(sb-bsd-sockets::host-ent-name

754

(sb-bsd-sockets:get-host-by-address address))))

755

756

#+(and sbcl (not win32))

757

(progn

758

(defun %setup-wait-list (wait-list)

759

(declare (ignore wait-list)))

760

761

(defun %add-waiter (wait-list waiter)

762

(push (socket waiter) (wait-list-%wait wait-list)))

763

764

(defun %remove-waiter (wait-list waiter)

765

(setf (wait-list-%wait wait-list)

766

(remove (socket waiter) (wait-list-%wait wait-list))))

767

768

(defun wait-for-input-internal (sockets &key timeout)

769

(with-mapped-conditions ()

770

(sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))

771

(sb-unix:fd-zero rfds)

772

(dolist (socket (wait-list-%wait sockets))

773

(sb-unix:fd-set

774

(sb-bsd-sockets:socket-file-descriptor socket)

775

rfds))

776

(multiple-value-bind

777

(secs musecs)

778

(split-timeout (or timeout 1))

779

(let* ((wait-list (wait-list-%wait sockets))

780

count err)

781

(if (null wait-list)

782

(setq count 0) ;; no need to call

783

(multiple-value-setq (count err)

784

(sb-unix:unix-fast-select

785

;; "invalid number of arguments: 0" if wait-list is null.

786

(1+ (reduce #'max wait-list

787

:key #'sb-bsd-sockets:socket-file-descriptor))

788

(sb-alien:addr rfds) nil nil

789

(when timeout secs) (when timeout musecs))))

790

(if (null count) ; something wrong in #'sb-unix:unix-fast-select

791

(unless (= err sb-unix:eintr)

792

(error (map-errno-error err)))

793

(when (< 0 count) ; do nothing if count = 0

794

;; process the result...

795

(dolist (x (wait-list-waiters sockets))

796

(when (sb-unix:fd-isset

797

(sb-bsd-sockets:socket-file-descriptor

798

(socket x))

799

rfds)

800

(setf (state x) :READ))))))))))

801

) ; progn

802

803

;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))

804

;;; Based on LispWorks version written by Erik Huelsmann.

805

806

#+win32 ; shared by ECL and SBCL

807

(eval-when (:compile-toplevel :load-toplevel :execute)

808

(defconstant +wsa-wait-failed+ #xffffffff)

809

(defconstant +wsa-infinite+ #xffffffff)

810

(defconstant +wsa-wait-event-0+ 0)

811

(defconstant +wsa-wait-timeout+ 258))

812

813

#+win32 ; shared by ECL and SBCL

814

(progn

815

(defconstant fd-read 1)

816

(defconstant fd-read-bit 0)

817

(defconstant fd-write 2)

818

(defconstant fd-write-bit 1)

819

(defconstant fd-oob 4)

820

(defconstant fd-oob-bit 2)

821

(defconstant fd-accept 8)

822

(defconstant fd-accept-bit 3)

823

(defconstant fd-connect 16)

824

(defconstant fd-connect-bit 4)

825

(defconstant fd-close 32)

826

(defconstant fd-close-bit 5)

827

(defconstant fd-qos 64)

828

(defconstant fd-qos-bit 6)

829

(defconstant fd-group-qos 128)

830

(defconstant fd-group-qos-bit 7)

831

(defconstant fd-routing-interface 256)

832

(defconstant fd-routing-interface-bit 8)

833

(defconstant fd-address-list-change 512)

834

(defconstant fd-address-list-change-bit 9)

835

(defconstant fd-max-events 10)

836

(defconstant fionread 1074030207)

837

838

;; Note: for ECL, socket-handle will return raw Windows Handle,

839

;; while SBCL returns OSF Handle instead.

840

(defun socket-handle (usocket)

841

(sb-bsd-sockets:socket-file-descriptor (socket usocket)))

842

843

(defun socket-ready-p (socket)

844

(if (typep socket 'stream-usocket)

845

(plusp (bytes-available-for-read socket))

846

(%ready-p socket)))

847

848

(defun waiting-required (sockets)

849

(notany #'socket-ready-p sockets))

850

851

(defun raise-usock-err (errno &optional socket)

852

(error 'unknown-error

853

:socket socket

854

:real-error errno))

855

856

(defun wait-for-input-internal (wait-list &key timeout)

857

(when (waiting-required (wait-list-waiters wait-list))

858

(let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)

859

nil

860

(if timeout

861

                                                   (truncate (* 1000 timeout))

862

+wsa-infinite+)

863

nil)))

864

(ecase rv

865

((#.+wsa-wait-event-0+)

866

(update-ready-and-state-slots wait-list))

867

((#.+wsa-wait-timeout+)) ; do nothing here

868

((#.+wsa-wait-failed+)

869

(maybe-wsa-error rv))))))

870

871

(defun %add-waiter (wait-list waiter)

872

(let ((events (etypecase waiter

873

(stream-server-usocket (logior fd-connect fd-accept fd-close))

874

(stream-usocket (logior fd-read))

875

(datagram-usocket (logior fd-read)))))

876

(maybe-wsa-error

877

(wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events)

878

waiter)))

879

880

(defun %remove-waiter (wait-list waiter)

881

(maybe-wsa-error

882

(wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)

883

waiter))

884

) ; progn

885

886

#+(and sbcl win32)

887

(progn

888

;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET

889

;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform. It

890

;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,

891

;; which is always machine word-sized (exactly as intptr_t;

892

;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not

893

;; enough -- potentially)."

894

;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011

895

(sb-alien:define-alien-type ws-socket sb-alien:signed)

896

897

(sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)

898

899

;; WS-EVENT was formerly defined as [internal, now removed] SB-ALIEN::HINSTANCE (synonym for SIGNED)

900

(sb-alien:define-alien-type ws-event sb-alien:signed)

901

902

(sb-alien:define-alien-type nil

903

(sb-alien:struct wsa-network-events

904

(network-events sb-alien:long)

905

(error-code (array sb-alien:int 10)))) ; 10 = fd-max-events

906

907

(sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)

908

ws-event) ; return type only

909

910

(sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)

911

(boolean #.sb-vm::n-machine-word-bits)

912

(event-object ws-event))

913

914

;; not used

915

(sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event)

916

(boolean #.sb-vm::n-machine-word-bits)

917

(event-object ws-event))

918

919

(sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)

920

sb-alien:int

921

(socket ws-socket)

922

(event-object ws-event)

923

(network-events (* (sb-alien:struct wsa-network-events))))

924

925

(sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)

926

sb-alien:int

927

(socket ws-socket)

928

(event-object ws-event)

929

(network-events sb-alien:long))

930

931

(sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)

932

ws-dword

933

(number-of-events ws-dword)

934

(events (* ws-event))

935

(wait-all-p (boolean #.sb-vm::n-machine-word-bits))

936

(timeout ws-dword)

937

(alertable-p (boolean #.sb-vm::n-machine-word-bits)))

938

939

(sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)

940

sb-alien:int

941

(socket ws-socket)

942

(cmd sb-alien:long)

943

(argp (* sb-alien:unsigned-long)))

944

945

(defun maybe-wsa-error (rv &optional socket)

946

(unless (zerop rv)

947

(raise-usock-err (sockint::wsa-get-last-error) socket)))

948

949

(defun os-socket-handle (usocket)

950

(sb-bsd-sockets:socket-file-descriptor (socket usocket)))

951

952

(defun bytes-available-for-read (socket)

953

(sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))

954

(maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))

955

socket)

956

(prog1 int-ptr

957

(when (plusp int-ptr)

958

(setf (state socket) :read)))))

959

960

(defun map-network-events (func network-events)

961

(let ((event-map (sb-alien:slot network-events 'network-events))

962

(error-array (sb-alien:slot network-events 'error-code)))

963

(unless (zerop event-map)

964

(dotimes (i fd-max-events)

965

           (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?

966

(funcall func (sb-alien:deref error-array i)))))))

967

968

(defun update-ready-and-state-slots (wait-list)

969

(loop with sockets = (wait-list-waiters wait-list)

970

for socket in sockets do

971

(if (%ready-p socket)

972

(progn

973

(setf (state socket) :READ))

974

(sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events)))

975

(let ((rv (wsa-enum-network-events (os-socket-handle socket)

976

                                              (os-wait-list-%wait wait-list)

977

                                              (sb-alien:addr network-events))))

978

(if (zerop rv)

979

(map-network-events

980

#'(lambda (err-code)

981

(if (zerop err-code)

982

(progn

983

(setf (state socket) :READ)

984

(when (stream-server-usocket-p socket)

985

(setf (%ready-p socket) t)))

986

(raise-usock-err err-code socket)))

987

network-events)

988

(maybe-wsa-error rv socket)))))))

989

990

(defun os-wait-list-%wait (wait-list)

991

(sb-alien:deref (wait-list-%wait wait-list)))

992

993

(defun (setf os-wait-list-%wait) (value wait-list)

994

(setf (sb-alien:deref (wait-list-%wait wait-list)) value))

995

996

;; "Event handles are leaking in current SBCL backend implementation,

997

;; because of SBCL-unfriendly usage of finalizers.

998

;;

999

;; "SBCL never calls a finalizer that closes over a finalized object: a

1000

;; reference from that closure prevents its collection forever. That's

1001

;; the case with USOCKET in %SETUP-WAIT-LIST.

1002

;;

1003

;; "I use the following redefinition of %SETUP-WAIT-LIST:

1004

;;

1005

;; "Of course it may be rewritten with more clarity, but you can see the

1006

;; core idea: I'm closing over those components of WAIT-LIST that I need

1007

;; for finalization, not the wait-list itself. With the original

1008

;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted

1009

;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."

1010

;;

1011

;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011

1012

1013

(defun %setup-wait-list (wait-list)

1014

(setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))

1015

(setf (os-wait-list-%wait wait-list) (wsa-event-create))

1016

(sb-ext:finalize wait-list

1017

(let ((event-handle (os-wait-list-%wait wait-list))

1018

(alien (wait-list-%wait wait-list)))

1019

#'(lambda ()

1020

(wsa-event-close event-handle)

1021

(unless (null alien)

1022

(sb-alien:free-alien alien))))))

1023

1024

) ; progn

1025

1026

#+(and (or ecl mkcl clasp) (not win32))

1027

(progn

1028

(defun wait-for-input-internal (wl &key timeout)

1029

(with-mapped-conditions ()

1030

(multiple-value-bind (secs usecs)

1031

(split-timeout (or timeout 1))

1032

(multiple-value-bind (result-fds err)

1033

(read-select wl (when timeout secs) usecs)

1034

(declare (ignore result-fds))

1035

(unless (null err)

1036

(error (map-errno-error err)))))))

1037

1038

(defun %setup-wait-list (wl)

1039

(setf (wait-list-%wait wl)

1040

(fdset-alloc)))

1041

1042

(defun %add-waiter (wl w)

1043

(declare (ignore wl w)))

1044

1045

(defun %remove-waiter (wl w)

1046

(declare (ignore wl w)))

1047

) ; progn

1048

1049

#+(and (or ecl mkcl clasp) win32 (not ecl-bytecmp))

1050

(progn

1051

(defun maybe-wsa-error (rv &optional syscall)

1052

(unless (zerop rv)

1053

(sb-bsd-sockets::socket-error syscall)))

1054

1055

(defun %setup-wait-list (wl)

1056

(setf (wait-list-%wait wl)

1057

(ffi:c-inline () () :int

1058

"WSAEVENT event;

1059

event = WSACreateEvent();

1060

@(return) = event;")))

1061

1062

(defun %add-waiter (wait-list waiter)

1063

(let ((events (etypecase waiter

1064

(stream-server-usocket (logior fd-connect fd-accept fd-close))

1065

(stream-usocket (logior fd-read))

1066

(datagram-usocket (logior fd-read)))))

1067

(maybe-wsa-error

1068

(ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)

1069

(:fixnum :fixnum :fixnum) :fixnum

1070

"int result;

1071

result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);

1072

@(return) = result;")

1073

'%add-waiter)))

1074

1075

(defun %remove-waiter (wait-list waiter)

1076

(maybe-wsa-error

1077

(ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))

1078

(:fixnum :fixnum) :fixnum

1079

"int result;

1080

result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);

1081

@(return) = result;")

1082

'%remove-waiter))

1083

1084

;; TODO: how to handle error (result) in this call?

1085

(declaim (inline %bytes-available-for-read))

1086

(defun %bytes-available-for-read (socket)

1087

(ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum

1088

"u_long nbytes;

1089

int result;

1090

nbytes = 0L;

1091

result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);

1092

@(return) = nbytes;"))

1093

1094

(defun bytes-available-for-read (socket)

1095

(let ((nbytes (%bytes-available-for-read socket)))

1096

(when (plusp nbytes)

1097

(setf (state socket) :read))

1098

nbytes))

1099

1100

(defun update-ready-and-state-slots (wait-list)

1101

(loop with sockets = (wait-list-waiters wait-list)

1102

for socket in sockets do

1103

(if (%ready-p socket)

1104

(setf (state socket) :READ)

1105

(let ((events (etypecase socket

1106

(stream-server-usocket (logior fd-connect fd-accept fd-close))

1107

(stream-usocket (logior fd-read))

1108

(datagram-usocket (logior fd-read)))))

1109

;; TODO: check the iErrorCode array

1110

(multiple-value-bind (valid-p ready-p)

1111

(ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum)

1112

                                                             (values :bool :bool)

1113

;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list)

1114

"WSANETWORKEVENTS network_events;

1115

int i, result;

1116

result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);

1117

if (!result) {

1118

@(return 0) = Ct;

1119

@(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;

1120

} else {

1121

@(return 0) = Cnil;

1122

@(return 1) = Cnil;

1123

}")

1124

(if valid-p

1125

(when ready-p

1126

(setf (state socket) :READ)

1127

(when (stream-server-usocket-p socket)

1128

(setf (%ready-p socket) t)))

1129

(sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))))

1130

1131

(defun wait-for-input-internal (wait-list &key timeout)

1132

(when (waiting-required (wait-list-waiters wait-list))

1133

(let ((rv (ffi:c-inline ((wait-list-%wait wait-list)

1134

(if timeout

1135

(truncate (* 1000 timeout))

1136

+wsa-infinite+))

1137

(:fixnum :fixnum) :fixnum

1138

"DWORD result;

1139

WSAEVENT events[1];

1140

events[0] = (WSAEVENT)#0;

1141

result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);

1142

@(return) = result;")))

1143

(ecase rv

1144

((#.+wsa-wait-event-0+)

1145

(update-ready-and-state-slots (wait-list-waiters wait-list)))

1146

((#.+wsa-wait-timeout+)) ; do nothing here

1147

((#.+wsa-wait-failed+)

1148

(sb-bsd-sockets::socket-error 'wait-for-input-internal))))))

1149

1150

) ; progn