Skip to content
Snippets Groups Projects
Verified Commit 6f5bd3ab authored by David Thompson's avatar David Thompson
Browse files

Add partial implementation of inet-pton to (guile).

parent 6dcd9029
No related branches found
No related tags found
1 merge request!284Bits and pieces needed for (web uri) support
Pipeline #1512846031 passed
......@@ -774,7 +774,6 @@
inet-makeaddr
inet-netof
inet-ntop
inet-pton
inherit-print-state
install-r6rs!
install-r7rs!
......@@ -1413,6 +1412,8 @@
>
>=
_
AF_INET
AF_INET6
SEEK_CUR
SEEK_END
SEEK_SET
......@@ -1630,6 +1631,7 @@
imag-part
include-from-path
(rename exact inexact->exact)
inet-pton
inexact?
inf
(rename infinite? inf?)
......@@ -2629,4 +2631,116 @@ Each call is of the form @code{(proc key value)}."
(define regexp/icase 'case-insensitive)
(define regexp/newline 'multiline)
(define regexp/notbol 'notbol)
(define regexp/noteol 'noteol))
(define regexp/noteol 'noteol)
;; Sockets
(define AF_INET 'ipv4)
(define AF_INET6 'ipv6)
(define (inet-pton family address)
(define (bad-address)
(error "bad address" family address))
(define (check-u8 x)
(unless (and x (<= 0 x 255)) (bad-address))
x)
(define (check-number x)
(unless (number? x) (bad-address))
x)
(define (read-decimal port)
(check-u8
(string->number
(list->string
(let lp ()
(match (peek-char port)
((and char (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(cons (read-char port) (lp)))
(_ '())))))))
(define (hex-digit? char)
(match char
((or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
#\a #\b #\c #\d #\e #\f
#\A #\B #\C #\D #\E #\F)
#t)
(_ #f)))
(define (read-hexadecimal port)
(check-number
(string->number
(list->string
(let lp ((k 0))
(match (peek-char port)
((? hex-digit?)
(if (= k 4)
(bad-address)
(cons (read-char port) (lp (1+ k)))))
(_ '()))))
16)))
(define (read-dot port)
(match (read-char port)
(#\. (values))
(_ (bad-address))))
(define (read-colon port)
(match (read-char port)
(#\: (values))
(_ (bad-address))))
(define (read-decimal-and-dot port)
(let ((n (read-decimal port)))
(read-dot port)
n))
(define (read-hexadecimal-and-colon port)
(let ((n (read-hexadecimal port)))
(read-colon port)
n))
(define (read-ipv6-groups port)
(define (iter)
(match (peek-char port)
((? eof-object?) '())
((? hex-digit?)
(let ((x (read-hexadecimal port)))
(match (read-char port)
((? eof-object?) (list x))
(#\: (cons x (iter))))))
(#\:
(read-char port)
'())))
(match (peek-char port)
((? eof-object?) '())
((? hex-digit?)
(iter))
(#\:
(read-char port)
(match (read-char port)
(#\: '())
(_ (bad-address))))))
(match family
('ipv4
(call-with-input-string address
(lambda (port)
(let ((a (read-decimal-and-dot port))
(b (read-decimal-and-dot port))
(c (read-decimal-and-dot port))
(d (read-decimal port)))
(if (eof-object? (peek-char port))
(logior (ash a 24)
(ash b 16)
(ash c 8)
d)
(bad-address))))))
;; TODO: IPv6 addresses with embedded IPv4 address.
('ipv6
(call-with-input-string address
(lambda (port)
(let* ((pre (read-ipv6-groups port))
(post (read-ipv6-groups port))
(pad (- 8 (+ (length pre) (length post)))))
(if (> pad 0)
(match (append pre (make-list pad 0) post)
((a b c d e f g h)
(logior (ash a 112)
(ash b 96)
(ash c 80)
(ash d 64)
(ash e 48)
(ash f 32)
(ash g 16)
h))
(_ (bad-address)))
(bad-address)))))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment